lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 # vim: ts=4 sts=4 sw=4:
   3 use strict;
   4 package CPAN;
   5 $CPAN::VERSION = '1.9301';
   6 $CPAN::VERSION =~ s/_//;
   7
   8 # we need to run chdir all over and we would get at wrong libraries
   9 # there
  10 use File::Spec ();
  11 BEGIN {
  12     if (File::Spec->can("rel2abs")) {
  13         for my $inc (@INC) {
  14             $inc = File::Spec->rel2abs($inc) unless ref $inc;
  15         }
  16     }
  17 }
  18 use CPAN::HandleConfig;
  19 use CPAN::Version;
  20 use CPAN::Debug;
  21 use CPAN::Queue;
  22 use CPAN::Tarzip;
  23 use CPAN::DeferedCode;
  24 use Carp ();
  25 use Config ();
  26 use Cwd qw(chdir);
  27 use DirHandle ();
  28 use Exporter ();
  29 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  30                                     # 5.005_04 does not work without
  31                                     # this
  32 use File::Basename ();
  33 use File::Copy ();
  34 use File::Find;
  35 use File::Path ();
  36 use FileHandle ();
  37 use Fcntl qw(:flock);
  38 use Safe ();
  39 use Sys::Hostname qw(hostname);
  40 use Text::ParseWords ();
  41 use Text::Wrap ();
  42
  43 # protect against "called too early"
  44 sub find_perl ();
  45 sub anycwd ();
  46
  47 no lib ".";
  48
  49 require Mac::BuildTools if $^O eq 'MacOS';
  50 if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
  51     $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
  52     my $rec = $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} .= ",$$";
  53     my @rec = split /,/, $rec;
  54     # warn "# Note: Recursive call of CPAN.pm detected\n";
  55     my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
  56     my %sleep = (
  57                  5 => 30,
  58                  6 => 60,
  59                  7 => 120,
  60                 );
  61     my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
  62     my $verbose = @rec >= 4;
  63     while (@rec) {
  64         $w .= sprintf " which has been called by process %d", pop @rec;
  65     }
  66     if ($sleep) {
  67         $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
  68     }
  69     if ($verbose) {
  70         warn $w;
  71     }
  72     local $| = 1;
  73     while ($sleep > 0) {
  74         printf "\r#%5d", --$sleep;
  75         sleep 1;
  76     }
  77     print "\n";
  78 }
  79 $ENV{PERL5_CPAN_IS_RUNNING}=$$;
  80 $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
  81
  82 END { $CPAN::End++; &cleanup; }
  83
  84 $CPAN::Signal ||= 0;
  85 $CPAN::Frontend ||= "CPAN::Shell";
  86 unless (@CPAN::Defaultsites) {
  87     @CPAN::Defaultsites = map {
  88         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  89     }
  90         "http://www.perl.org/CPAN/",
  91             "ftp://ftp.perl.org/pub/CPAN/";
  92 }
  93 # $CPAN::iCwd (i for initial)
  94 $CPAN::iCwd ||= CPAN::anycwd();
  95 $CPAN::Perl ||= CPAN::find_perl();
  96 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  97 $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
  98 $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
  99
 100 # our globals are getting a mess
 101 use vars qw(
 102             $AUTOLOAD
 103             $Be_Silent
 104             $CONFIG_DIRTY
 105             $Defaultdocs
 106             $Echo_readline
 107             $Frontend
 108             $GOTOSHELL
 109             $HAS_USABLE
 110             $Have_warned
 111             $MAX_RECURSION
 112             $META
 113             $RUN_DEGRADED
 114             $Signal
 115             $SQLite
 116             $Suppress_readline
 117             $VERSION
 118             $autoload_recursion
 119             $term
 120             @Defaultsites
 121             @EXPORT
 122            );
 123
 124 $MAX_RECURSION = 32;
 125
 126 @CPAN::ISA = qw(CPAN::Debug Exporter);
 127
 128 # note that these functions live in CPAN::Shell and get executed via
 129 # AUTOLOAD when called directly
 130 @EXPORT = qw(
 131              autobundle
 132              bundle
 133              clean
 134              cvs_import
 135              expand
 136              force
 137              fforce
 138              get
 139              install
 140              install_tested
 141              is_tested
 142              make
 143              mkmyconfig
 144              notest
 145              perldoc
 146              readme
 147              recent
 148              recompile
 149              report
 150              shell
 151              smoke
 152              test
 153              upgrade
 154             );
 155
 156 sub soft_chdir_with_alternatives ($);
 157
 158 {
 159     $autoload_recursion ||= 0;
 160
 161     #-> sub CPAN::AUTOLOAD ;
 162     sub AUTOLOAD {
 163         $autoload_recursion++;
 164         my($l) = $AUTOLOAD;
 165         $l =~ s/.*:://;
 166         if ($CPAN::Signal) {
 167             warn "Refusing to autoload '$l' while signal pending";
 168             $autoload_recursion--;
 169             return;
 170         }
 171         if ($autoload_recursion > 1) {
 172             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 173             warn "Refusing to autoload $fullcommand in recursion\n";
 174             $autoload_recursion--;
 175             return;
 176         }
 177         my(%export);
 178         @export{@EXPORT} = '';
 179         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 180         if (exists $export{$l}) {
 181             CPAN::Shell->$l(@_);
 182         } else {
 183             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 184                 qq{Type ? for help.\n});
 185         }
 186         $autoload_recursion--;
 187     }
 188 }
 189
 190 {
 191     my $x = *SAVEOUT; # avoid warning
 192     open($x,">&STDOUT") or die "dup failed";
 193     my $redir = 0;
 194     sub _redirect(@) {
 195         #die if $redir;
 196         local $_;
 197         push(@_,undef);
 198         while(defined($_=shift)) {
 199             if (s/^\s*>//){
 200                 my ($m) = s/^>// ? ">" : "";
 201                 s/\s+//;
 202                 $_=shift unless length;
 203                 die "no dest" unless defined;
 204                 open(STDOUT,">$m$_") or die "open:$_:$!\n";
 205                 $redir=1;
 206             } elsif ( s/^\s*\|\s*// ) {
 207                 my $pipe="| $_";
 208                 while(defined($_[0])){
 209                     $pipe .= ' ' . shift;
 210                 }
 211                 open(STDOUT,$pipe) or die "open:$pipe:$!\n";
 212                 $redir=1;
 213             } else {
 214                 push(@_,$_);
 215             }
 216         }
 217         return @_;
 218     }
 219     sub _unredirect {
 220         return unless $redir;
 221         $redir = 0;
 222         ## redirect: unredirect and propagate errors.  explicit close to wait for pipe.
 223         close(STDOUT);
 224         open(STDOUT,">&SAVEOUT");
 225         die "$@" if "$@";
 226         ## redirect: done
 227     }
 228 }
 229
 230 #-> sub CPAN::shell ;
 231 sub shell {
 232     my($self) = @_;
 233     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 234     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 235
 236     my $oprompt = shift || CPAN::Prompt->new;
 237     my $prompt = $oprompt;
 238     my $commandline = shift || "";
 239     $CPAN::CurrentCommandId ||= 1;
 240
 241     local($^W) = 1;
 242     unless ($Suppress_readline) {
 243         require Term::ReadLine;
 244         if (! $term
 245             or
 246             $term->ReadLine eq "Term::ReadLine::Stub"
 247            ) {
 248             $term = Term::ReadLine->new('CPAN Monitor');
 249         }
 250         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 251             my $attribs = $term->Attribs;
 252             $attribs->{attempted_completion_function} = sub {
 253                 &CPAN::Complete::gnu_cpl;
 254             }
 255         } else {
 256             $readline::rl_completion_function =
 257                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 258         }
 259         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 260             unless ($term->can("AddHistory")) {
 261                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 262                 last;
 263             }
 264             $META->readhist($term,$histfile);
 265         }}
 266         for ($CPAN::Config->{term_ornaments}) { # alias
 267             local $Term::ReadLine::termcap_nowarn = 1;
 268             $term->ornaments($_) if defined;
 269         }
 270         # $term->OUT is autoflushed anyway
 271         my $odef = select STDERR;
 272         $| = 1;
 273         select STDOUT;
 274         $| = 1;
 275         select $odef;
 276     }
 277
 278     $META->checklock();
 279     my @cwd = grep { defined $_ and length $_ }
 280         CPAN::anycwd(),
 281               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 282                     File::Spec->rootdir();
 283     my $try_detect_readline;
 284     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 285     unless ($CPAN::Config->{inhibit_startup_message}) {
 286         my $rl_avail = $Suppress_readline ? "suppressed" :
 287             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 288                 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
 289         $CPAN::Frontend->myprint(
 290                                  sprintf qq{
 291 cpan shell -- CPAN exploration and modules installation (v%s)
 292 ReadLine support %s
 293
 294 },
 295                                  $CPAN::VERSION,
 296                                  $rl_avail
 297                                 )
 298     }
 299     my($continuation) = "";
 300     my $last_term_ornaments;
 301   SHELLCOMMAND: while () {
 302         if ($Suppress_readline) {
 303             if ($Echo_readline) {
 304                 $|=1;
 305             }
 306             print $prompt;
 307             last SHELLCOMMAND unless defined ($_ = <> );
 308             if ($Echo_readline) {
 309                 # backdoor: I could not find a way to record sessions
 310                 print $_;
 311             }
 312             chomp;
 313         } else {
 314             last SHELLCOMMAND unless
 315                 defined ($_ = $term->readline($prompt, $commandline));
 316         }
 317         $_ = "$continuation$_" if $continuation;
 318         s/^\s+//;
 319         next SHELLCOMMAND if /^$/;
 320         s/^\s*\?\s*/help /;
 321         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 322             last SHELLCOMMAND;
 323         } elsif (s/\\$//s) {
 324             chomp;
 325             $continuation = $_;
 326             $prompt = "    > ";
 327         } elsif (/^\!/) {
 328             s/^\!//;
 329             my($eval) = $_;
 330             package CPAN::Eval;
 331             use strict;
 332             use vars qw($import_done);
 333             CPAN->import(':DEFAULT') unless $import_done++;
 334             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 335             eval($eval);
 336             warn $@ if $@;
 337             $continuation = "";
 338             $prompt = $oprompt;
 339         } elsif (/./) {
 340             my(@line);
 341             eval { @line = Text::ParseWords::shellwords($_) };
 342             warn($@), next SHELLCOMMAND if $@;
 343             warn("Text::Parsewords could not parse the line [$_]"),
 344                 next SHELLCOMMAND unless @line;
 345             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 346             my $command = shift @line;
 347             eval {
 348                 local (*STDOUT)=*STDOUT;
 349                 @line = _redirect(@line);
 350                 CPAN::Shell->$command(@line)
 351               };
 352             _unredirect;
 353             if ($@) {
 354                 my $err = "$@";
 355                 if ($err =~ /\S/) {
 356                     require Carp;
 357                     require Dumpvalue;
 358                     my $dv = Dumpvalue->new(tick => '"');
 359                     Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
 360                 }
 361             }
 362             if ($command =~ /^(
 363                              # classic commands
 364                              make
 365                              |test
 366                              |install
 367                              |clean
 368
 369                              # pragmas for classic commands
 370                              |ff?orce
 371                              |notest
 372
 373                              # compounds
 374                              |report
 375                              |smoke
 376                              |upgrade
 377                             )$/x) {
 378                 # only commands that tell us something about failed distros
 379                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 380             }
 381             soft_chdir_with_alternatives(\@cwd);
 382             $CPAN::Frontend->myprint("\n");
 383             $continuation = "";
 384             $CPAN::CurrentCommandId++;
 385             $prompt = $oprompt;
 386         }
 387     } continue {
 388         $commandline = ""; # I do want to be able to pass a default to
 389                            # shell, but on the second command I see no
 390                            # use in that
 391         $Signal=0;
 392         CPAN::Queue->nullify_queue;
 393         if ($try_detect_readline) {
 394             if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 395                 ||
 396                 $CPAN::META->has_inst("Term::ReadLine::Perl")
 397             ) {
 398                 delete $INC{"Term/ReadLine.pm"};
 399                 my $redef = 0;
 400                 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 401                 require Term::ReadLine;
 402                 $CPAN::Frontend->myprint("\n$redef subroutines in ".
 403                                          "Term::ReadLine redefined\n");
 404                 $GOTOSHELL = 1;
 405             }
 406         }
 407         if ($term and $term->can("ornaments")) {
 408             for ($CPAN::Config->{term_ornaments}) { # alias
 409                 if (defined $_) {
 410                     if (not defined $last_term_ornaments
 411                         or $_ != $last_term_ornaments
 412                     ) {
 413                         local $Term::ReadLine::termcap_nowarn = 1;
 414                         $term->ornaments($_);
 415                         $last_term_ornaments = $_;
 416                     }
 417                 } else {
 418                     undef $last_term_ornaments;
 419                 }
 420             }
 421         }
 422         for my $class (qw(Module Distribution)) {
 423             # again unsafe meta access?
 424             for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 425                 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 426                 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 427                 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 428             }
 429         }
 430         if ($GOTOSHELL) {
 431             $GOTOSHELL = 0; # not too often
 432             $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 433             @_ = ($oprompt,"");
 434             goto &shell;
 435         }
 436     }
 437     soft_chdir_with_alternatives(\@cwd);
 438 }
 439
 440 #-> CPAN::soft_chdir_with_alternatives ;
 441 sub soft_chdir_with_alternatives ($) {
 442     my($cwd) = @_;
 443     unless (@$cwd) {
 444         my $root = File::Spec->rootdir();
 445         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 446 Trying '$root' as temporary haven.
 447 });
 448         push @$cwd, $root;
 449     }
 450     while () {
 451         if (chdir $cwd->[0]) {
 452             return;
 453         } else {
 454             if (@$cwd>1) {
 455                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 456 Trying to chdir to "$cwd->[1]" instead.
 457 });
 458                 shift @$cwd;
 459             } else {
 460                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 461             }
 462         }
 463     }
 464 }
 465
 466 sub _flock {
 467     my($fh,$mode) = @_;
 468     if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
 469         return flock $fh, $mode;
 470     } elsif (!$Have_warned->{"d_flock"}++) {
 471         $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
 472         $CPAN::Frontend->mysleep(5);
 473         return 1;
 474     } else {
 475         return 1;
 476     }
 477 }
 478
 479 sub _yaml_module () {
 480     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 481     if (
 482         $yaml_module ne "YAML"
 483         &&
 484         !$CPAN::META->has_inst($yaml_module)
 485        ) {
 486         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 487         $yaml_module = "YAML";
 488     }
 489     if ($yaml_module eq "YAML"
 490         &&
 491         $CPAN::META->has_inst($yaml_module)
 492         &&
 493         $YAML::VERSION < 0.60
 494         &&
 495         !$Have_warned->{"YAML"}++
 496        ) {
 497         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 498                                 "I'll continue but problems are *very* likely to happen.\n"
 499                                );
 500         $CPAN::Frontend->mysleep(5);
 501     }
 502     return $yaml_module;
 503 }
 504
 505 # CPAN::_yaml_loadfile
 506 sub _yaml_loadfile {
 507     my($self,$local_file) = @_;
 508     return +[] unless -s $local_file;
 509     my $yaml_module = _yaml_module;
 510     if ($CPAN::META->has_inst($yaml_module)) {
 511         # temporarly enable yaml code deserialisation
 512         no strict 'refs';
 513         # 5.6.2 could not do the local() with the reference
 514         # so we do it manually instead
 515         my $old_loadcode = ${"$yaml_module\::LoadCode"};
 516         ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
 517
 518         my ($code, @yaml);
 519         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 520             eval { @yaml = $code->($local_file); };
 521             if ($@) {
 522                 # this shall not be done by the frontend
 523                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 524             }
 525         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 526             local *FH;
 527             open FH, $local_file or die "Could not open '$local_file': $!";
 528             local $/;
 529             my $ystream = <FH>;
 530             eval { @yaml = $code->($ystream); };
 531             if ($@) {
 532                 # this shall not be done by the frontend
 533                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 534             }
 535         }
 536         ${"$yaml_module\::LoadCode"} = $old_loadcode;
 537         return \@yaml;
 538     } else {
 539         # this shall not be done by the frontend
 540         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 541     }
 542     return +[];
 543 }
 544
 545 # CPAN::_yaml_dumpfile
 546 sub _yaml_dumpfile {
 547     my($self,$local_file,@what) = @_;
 548     my $yaml_module = _yaml_module;
 549     if ($CPAN::META->has_inst($yaml_module)) {
 550         my $code;
 551         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 552             $code = UNIVERSAL::can($yaml_module, "Dump");
 553             eval { print $local_file $code->(@what) };
 554         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 555             eval { $code->($local_file,@what); };
 556         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 557             local *FH;
 558             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 559             print FH $code->(@what);
 560         }
 561         if ($@) {
 562             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 563         }
 564     } else {
 565         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 566             # I think this case does not justify a warning at all
 567         } else {
 568             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 569         }
 570     }
 571 }
 572
 573 sub _init_sqlite () {
 574     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 575         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 576             unless $Have_warned->{"CPAN::SQLite"}++;
 577         return;
 578     }
 579     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 580     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 581 }
 582
 583 {
 584     my $negative_cache = {};
 585     sub _sqlite_running {
 586         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 587             # need to cache the result, otherwise too slow
 588             return $negative_cache->{fact};
 589         } else {
 590             $negative_cache = {}; # reset
 591         }
 592         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 593         return $ret if $ret; # fast anyway
 594         $negative_cache->{time} = time;
 595         return $negative_cache->{fact} = $ret;
 596     }
 597 }
 598
 599 package CPAN::CacheMgr;
 600 use strict;
 601 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 602 use Cwd qw(chdir);
 603 use File::Find;
 604
 605 package CPAN::FTP;
 606 use strict;
 607 use Fcntl qw(:flock);
 608 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
 609 @CPAN::FTP::ISA = qw(CPAN::Debug);
 610
 611 package CPAN::LWP::UserAgent;
 612 use strict;
 613 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 614 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 615
 616 package CPAN::Complete;
 617 use strict;
 618 @CPAN::Complete::ISA = qw(CPAN::Debug);
 619 # Q: where is the "How do I add a new command" HOWTO?
 620 # A: svn diff -r 1048:1049 where andk added the report command
 621 @CPAN::Complete::COMMANDS = sort qw(
 622                                     ? ! a b d h i m o q r u
 623                                     autobundle
 624                                     bye
 625                                     clean
 626                                     cvs_import
 627                                     dump
 628                                     exit
 629                                     failed
 630                                     force
 631                                     fforce
 632                                     hosts
 633                                     install
 634                                     install_tested
 635                                     is_tested
 636                                     look
 637                                     ls
 638                                     make
 639                                     mkmyconfig
 640                                     notest
 641                                     perldoc
 642                                     quit
 643                                     readme
 644                                     recent
 645                                     recompile
 646                                     reload
 647                                     report
 648                                     reports
 649                                     scripts
 650                                     smoke
 651                                     test
 652                                     upgrade
 653 );
 654
 655 package CPAN::Index;
 656 use strict;
 657 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 658 @CPAN::Index::ISA = qw(CPAN::Debug);
 659 $LAST_TIME ||= 0;
 660 $DATE_OF_03 ||= 0;
 661 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 662 sub PROTOCOL { 2.0 }
 663
 664 package CPAN::InfoObj;
 665 use strict;
 666 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 667
 668 package CPAN::Author;
 669 use strict;
 670 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 671
 672 package CPAN::Distribution;
 673 use strict;
 674 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 675
 676 package CPAN::Bundle;
 677 use strict;
 678 @CPAN::Bundle::ISA = qw(CPAN::Module);
 679
 680 package CPAN::Module;
 681 use strict;
 682 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 683
 684 package CPAN::Exception::RecursiveDependency;
 685 use strict;
 686 use overload '""' => "as_string";
 687
 688 # a module sees its distribution (no version)
 689 # a distribution sees its prereqs (which are module names) (usually with versions)
 690 # a bundle sees its module names and/or its distributions (no version)
 691
 692 sub new {
 693     my($class) = shift;
 694     my($deps) = shift;
 695     my (@deps,%seen,$loop_starts_with);
 696   DCHAIN: for my $dep (@$deps) {
 697         push @deps, {name => $dep, display_as => $dep};
 698         if ($seen{$dep}++) {
 699             $loop_starts_with = $dep;
 700             last DCHAIN;
 701         }
 702     }
 703     my $in_loop = 0;
 704     for my $i (0..$#deps) {
 705         my $x = $deps[$i]{name};
 706         $in_loop ||= $x eq $loop_starts_with;
 707         my $xo = CPAN::Shell->expandany($x) or next;
 708         if ($xo->isa("CPAN::Module")) {
 709             my $have = $xo->inst_version || "N/A";
 710             my($want,$d,$want_type);
 711             if ($i>0 and $d = $deps[$i-1]{name}) {
 712                 my $do = CPAN::Shell->expandany($d);
 713                 $want = $do->{prereq_pm}{requires}{$x};
 714                 if (defined $want) {
 715                     $want_type = "requires: ";
 716                 } else {
 717                     $want = $do->{prereq_pm}{build_requires}{$x};
 718                     if (defined $want) {
 719                         $want_type = "build_requires: ";
 720                     } else {
 721                         $want_type = "unknown status";
 722                         $want = "???";
 723                     }
 724                 }
 725             } else {
 726                 $want = $xo->cpan_version;
 727                 $want_type = "want: ";
 728             }
 729             $deps[$i]{have} = $have;
 730             $deps[$i]{want_type} = $want_type;
 731             $deps[$i]{want} = $want;
 732             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 733         } elsif ($xo->isa("CPAN::Distribution")) {
 734             $deps[$i]{display_as} = $xo->pretty_id;
 735             if ($in_loop) {
 736                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 737             } else {
 738                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 739             }
 740             $xo->store_persistent_state; # otherwise I will not reach
 741                                          # all involved parties for
 742                                          # the next session
 743         }
 744     }
 745     bless { deps => \@deps }, $class;
 746 }
 747
 748 sub as_string {
 749     my($self) = shift;
 750     my $ret = "\nRecursive dependency detected:\n    ";
 751     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 752     $ret .= ".\nCannot resolve.\n";
 753     $ret;
 754 }
 755
 756 package CPAN::Exception::yaml_not_installed;
 757 use strict;
 758 use overload '""' => "as_string";
 759
 760 sub new {
 761     my($class,$module,$file,$during) = @_;
 762     bless { module => $module, file => $file, during => $during }, $class;
 763 }
 764
 765 sub as_string {
 766     my($self) = shift;
 767     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 768 }
 769
 770 package CPAN::Exception::yaml_process_error;
 771 use strict;
 772 use overload '""' => "as_string";
 773
 774 sub new {
 775     my($class,$module,$file,$during,$error) = @_;
 776     # my $at = Carp::longmess(""); # XXX find something more beautiful
 777     bless { module => $module,
 778             file => $file,
 779             during => $during,
 780             error => $error,
 781             # at => $at,
 782           }, $class;
 783 }
 784
 785 sub as_string {
 786     my($self) = shift;
 787     if ($self->{during}) {
 788         if ($self->{file}) {
 789             if ($self->{module}) {
 790                 if ($self->{error}) {
 791                     return "Alert: While trying to '$self->{during}' YAML file\n".
 792                         " '$self->{file}'\n".
 793                             "with '$self->{module}' the following error was encountered:\n".
 794                                 "  $self->{error}\n";
 795                 } else {
 796                     return "Alert: While trying to '$self->{during}' YAML file\n".
 797                         " '$self->{file}'\n".
 798                             "with '$self->{module}' some unknown error was encountered\n";
 799                 }
 800             } else {
 801                 return "Alert: While trying to '$self->{during}' YAML file\n".
 802                     " '$self->{file}'\n".
 803                         "some unknown error was encountered\n";
 804             }
 805         } else {
 806             return "Alert: While trying to '$self->{during}' some YAML file\n".
 807                     "some unknown error was encountered\n";
 808         }
 809     } else {
 810         return "Alert: unknown error encountered\n";
 811     }
 812 }
 813
 814 package CPAN::Prompt; use overload '""' => "as_string";
 815 use vars qw($prompt);
 816 $prompt = "cpan> ";
 817 $CPAN::CurrentCommandId ||= 0;
 818 sub new {
 819     bless {}, shift;
 820 }
 821 sub as_string {
 822     my $word = "cpan";
 823     unless ($CPAN::META->{LOCK}) {
 824         $word = "nolock_cpan";
 825     }
 826     if ($CPAN::Config->{commandnumber_in_prompt}) {
 827         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 828     } else {
 829         "$word> ";
 830     }
 831 }
 832
 833 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 834 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 835 # planned are things like age or quality
 836 sub new {
 837     my($class,%args) = @_;
 838     bless {
 839            %args
 840           }, $class;
 841 }
 842 sub as_string {
 843     my($self) = @_;
 844     $self->text;
 845 }
 846 sub text {
 847     my($self,$set) = @_;
 848     if (defined $set) {
 849         $self->{TEXT} = $set;
 850     }
 851     $self->{TEXT};
 852 }
 853
 854 package CPAN::Distrostatus;
 855 use overload '""' => "as_string",
 856     fallback => 1;
 857 use vars qw($something_has_failed_at);
 858 sub new {
 859     my($class,$arg) = @_;
 860     my $failed = substr($arg,0,2) eq "NO";
 861     if ($failed) {
 862         $something_has_failed_at = $CPAN::CurrentCommandId;
 863     }
 864     bless {
 865            TEXT => $arg,
 866            FAILED => $failed,
 867            COMMANDID => $CPAN::CurrentCommandId,
 868            TIME => time,
 869           }, $class;
 870 }
 871 sub something_has_just_failed () {
 872     defined $something_has_failed_at &&
 873         $something_has_failed_at == $CPAN::CurrentCommandId;
 874 }
 875 sub commandid { shift->{COMMANDID} }
 876 sub failed { shift->{FAILED} }
 877 sub text {
 878     my($self,$set) = @_;
 879     if (defined $set) {
 880         $self->{TEXT} = $set;
 881     }
 882     $self->{TEXT};
 883 }
 884 sub as_string {
 885     my($self) = @_;
 886     $self->text;
 887 }
 888
 889 package CPAN::Shell;
 890 use strict;
 891 use vars qw(
 892             $ADVANCED_QUERY
 893             $AUTOLOAD
 894             $COLOR_REGISTERED
 895             $Help
 896             $autoload_recursion
 897             $reload
 898             @ISA
 899             @relo
 900            );
 901 @relo =     (
 902              "CPAN.pm",
 903              "CPAN/Debug.pm",
 904              "CPAN/Distroprefs.pm",
 905              "CPAN/FirstTime.pm",
 906              "CPAN/HandleConfig.pm",
 907              "CPAN/Kwalify.pm",
 908              "CPAN/Queue.pm",
 909              "CPAN/Reporter/Config.pm",
 910              "CPAN/Reporter/History.pm",
 911              "CPAN/Reporter/PrereqCheck.pm",
 912              "CPAN/Reporter.pm",
 913              "CPAN/SQLite.pm",
 914              "CPAN/Tarzip.pm",
 915              "CPAN/Version.pm",
 916             );
 917 # record the initial timestamp for reload.
 918 $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
 919 @CPAN::Shell::ISA = qw(CPAN::Debug);
 920 use Cwd qw(chdir);
 921 $COLOR_REGISTERED ||= 0;
 922 $Help = {
 923          '?' => \"help",
 924          '!' => "eval the rest of the line as perl",
 925          a => "whois author",
 926          autobundle => "wtite inventory into a bundle file",
 927          b => "info about bundle",
 928          bye => \"quit",
 929          clean => "clean up a distribution's build directory",
 930          # cvs_import
 931          d => "info about a distribution",
 932          # dump
 933          exit => \"quit",
 934          failed => "list all failed actions within current session",
 935          fforce => "redo a command from scratch",
 936          force => "redo a command",
 937          h => \"help",
 938          help => "overview over commands; 'help ...' explains specific commands",
 939          hosts => "statistics about recently used hosts",
 940          i => "info about authors/bundles/distributions/modules",
 941          install => "install a distribution",
 942          install_tested => "install all distributions tested OK",
 943          is_tested => "list all distributions tested OK",
 944          look => "open a subshell in a distribution's directory",
 945          ls => "list distributions according to a glob",
 946          m => "info about a module",
 947          make => "make/build a distribution",
 948          mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 949          notest => "run a (usually install) command but leave out the test phase",
 950          o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 951          perldoc => "try to get a manpage for a module",
 952          q => \"quit",
 953          quit => "leave the cpan shell",
 954          r => "review over upgradeable modules",
 955          readme => "display the README of a distro woth a pager",
 956          recent => "show recent uploads to the CPAN",
 957          # recompile
 958          reload => "'reload cpan' or 'reload index'",
 959          report => "test a distribution and send a test report to cpantesters",
 960          reports => "info about reported tests from cpantesters",
 961          # scripts
 962          # smoke
 963          test => "test a distribution",
 964          u => "display uninstalled modules",
 965          upgrade => "combine 'r' command with immediate installation",
 966         };
 967 {
 968     $autoload_recursion   ||= 0;
 969
 970     #-> sub CPAN::Shell::AUTOLOAD ;
 971     sub AUTOLOAD {
 972         $autoload_recursion++;
 973         my($l) = $AUTOLOAD;
 974         my $class = shift(@_);
 975         # warn "autoload[$l] class[$class]";
 976         $l =~ s/.*:://;
 977         if ($CPAN::Signal) {
 978             warn "Refusing to autoload '$l' while signal pending";
 979             $autoload_recursion--;
 980             return;
 981         }
 982         if ($autoload_recursion > 1) {
 983             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 984             warn "Refusing to autoload $fullcommand in recursion\n";
 985             $autoload_recursion--;
 986             return;
 987         }
 988         if ($l =~ /^w/) {
 989             # XXX needs to be reconsidered
 990             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 991                 CPAN::WAIT->$l(@_);
 992             } else {
 993                 $CPAN::Frontend->mywarn(qq{
 994 Commands starting with "w" require CPAN::WAIT to be installed.
 995 Please consider installing CPAN::WAIT to use the fulltext index.
 996 For this you just need to type
 997     install CPAN::WAIT
 998 });
 999             }
1000         } else {
1001             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
1002                                     qq{Type ? for help.
1003 });
1004         }
1005         $autoload_recursion--;
1006     }
1007 }
1008
1009 package CPAN;
1010 use strict;
1011
1012 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
1013
1014 # from here on only subs.
1015 ################################################################################
1016
1017 sub _perl_fingerprint {
1018     my($self,$other_fingerprint) = @_;
1019     my $dll = eval {OS2::DLLname()};
1020     my $mtime_dll = 0;
1021     if (defined $dll) {
1022         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
1023     }
1024     my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
1025     my $this_fingerprint = {
1026                             '$^X' => CPAN::find_perl,
1027                             sitearchexp => $Config::Config{sitearchexp},
1028                             'mtime_$^X' => $mtime_perl,
1029                             'mtime_dll' => $mtime_dll,
1030                            };
1031     if ($other_fingerprint) {
1032         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
1033             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
1034         }
1035         # mandatory keys since 1.88_57
1036         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
1037             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
1038         }
1039         return 1;
1040     } else {
1041         return $this_fingerprint;
1042     }
1043 }
1044
1045 sub suggest_myconfig () {
1046   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
1047         $CPAN::Frontend->myprint("You don't seem to have a user ".
1048                                  "configuration (MyConfig.pm) yet.\n");
1049         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
1050                                               "user configuration now? (Y/n)",
1051                                               "yes");
1052         if($new =~ m{^y}i) {
1053             CPAN::Shell->mkmyconfig();
1054             return &checklock;
1055         } else {
1056             $CPAN::Frontend->mydie("OK, giving up.");
1057         }
1058     }
1059 }
1060
1061 #-> sub CPAN::all_objects ;
1062 sub all_objects {
1063     my($mgr,$class) = @_;
1064     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1065     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
1066     CPAN::Index->reload;
1067     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
1068 }
1069
1070 # Called by shell, not in batch mode. In batch mode I see no risk in
1071 # having many processes updating something as installations are
1072 # continually checked at runtime. In shell mode I suspect it is
1073 # unintentional to open more than one shell at a time
1074
1075 #-> sub CPAN::checklock ;
1076 sub checklock {
1077     my($self) = @_;
1078     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
1079     if (-f $lockfile && -M _ > 0) {
1080         my $fh = FileHandle->new($lockfile) or
1081             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
1082         my $otherpid  = <$fh>;
1083         my $otherhost = <$fh>;
1084         $fh->close;
1085         if (defined $otherpid && $otherpid) {
1086             chomp $otherpid;
1087         }
1088         if (defined $otherhost && $otherhost) {
1089             chomp $otherhost;
1090         }
1091         my $thishost  = hostname();
1092         if (defined $otherhost && defined $thishost &&
1093             $otherhost ne '' && $thishost ne '' &&
1094             $otherhost ne $thishost) {
1095             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
1096                                            "reports other host $otherhost and other ".
1097                                            "process $otherpid.\n".
1098                                            "Cannot proceed.\n"));
1099         } elsif ($RUN_DEGRADED) {
1100             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
1101         } elsif (defined $otherpid && $otherpid) {
1102             return if $$ == $otherpid; # should never happen
1103             $CPAN::Frontend->mywarn(
1104                                     qq{
1105 There seems to be running another CPAN process (pid $otherpid).  Contacting...
1106 });
1107             if (kill 0, $otherpid or $!{EPERM}) {
1108                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1109                 my($ans) =
1110                     CPAN::Shell::colorable_makemaker_prompt
1111                         (qq{Shall I try to run in degraded }.
1112                         qq{mode? (Y/n)},"y");
1113                 if ($ans =~ /^y/i) {
1114                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1115 Please report if something unexpected happens\n");
1116                     $RUN_DEGRADED = 1;
1117                     for ($CPAN::Config) {
1118                         # XXX
1119                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1120                         $_->{commandnumber_in_prompt} = 0; # visibility
1121                         $_->{histfile} = "";               # who should win otherwise?
1122                         $_->{cache_metadata} = 0;          # better would be a lock?
1123                         $_->{use_sqlite} = 0;              # better would be a write lock!
1124                     }
1125                 } else {
1126                     $CPAN::Frontend->mydie("
1127 You may want to kill the other job and delete the lockfile. On UNIX try:
1128     kill $otherpid
1129     rm $lockfile
1130 ");
1131                 }
1132             } elsif (-w $lockfile) {
1133                 my($ans) =
1134                     CPAN::Shell::colorable_makemaker_prompt
1135                         (qq{Other job not responding. Shall I overwrite }.
1136                         qq{the lockfile '$lockfile'? (Y/n)},"y");
1137             $CPAN::Frontend->myexit("Ok, bye\n")
1138                 unless $ans =~ /^y/i;
1139             } else {
1140                 Carp::croak(
1141                     qq{Lockfile '$lockfile' not writeable by you. }.
1142                     qq{Cannot proceed.\n}.
1143                     qq{    On UNIX try:\n}.
1144                     qq{    rm '$lockfile'\n}.
1145                     qq{  and then rerun us.\n}
1146                 );
1147             }
1148         } else {
1149             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1150                                            "'$lockfile', please remove. Cannot proceed.\n"));
1151         }
1152     }
1153     my $dotcpan = $CPAN::Config->{cpan_home};
1154     eval { File::Path::mkpath($dotcpan);};
1155     if ($@) {
1156         # A special case at least for Jarkko.
1157         my $firsterror = $@;
1158         my $seconderror;
1159         my $symlinkcpan;
1160         if (-l $dotcpan) {
1161             $symlinkcpan = readlink $dotcpan;
1162             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1163             eval { File::Path::mkpath($symlinkcpan); };
1164             if ($@) {
1165                 $seconderror = $@;
1166             } else {
1167                 $CPAN::Frontend->mywarn(qq{
1168 Working directory $symlinkcpan created.
1169 });
1170             }
1171         }
1172         unless (-d $dotcpan) {
1173             my $mess = qq{
1174 Your configuration suggests "$dotcpan" as your
1175 CPAN.pm working directory. I could not create this directory due
1176 to this error: $firsterror\n};
1177             $mess .= qq{
1178 As "$dotcpan" is a symlink to "$symlinkcpan",
1179 I tried to create that, but I failed with this error: $seconderror
1180 } if $seconderror;
1181             $mess .= qq{
1182 Please make sure the directory exists and is writable.
1183 };
1184             $CPAN::Frontend->mywarn($mess);
1185             return suggest_myconfig;
1186         }
1187     } # $@ after eval mkpath $dotcpan
1188     if (0) { # to test what happens when a race condition occurs
1189         for (reverse 1..10) {
1190             print $_, "\n";
1191             sleep 1;
1192         }
1193     }
1194     # locking
1195     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1196         my $fh;
1197         unless ($fh = FileHandle->new("+>>$lockfile")) {
1198             if ($! =~ /Permission/) {
1199                 $CPAN::Frontend->mywarn(qq{
1200
1201 Your configuration suggests that CPAN.pm should use a working
1202 directory of
1203     $CPAN::Config->{cpan_home}
1204 Unfortunately we could not create the lock file
1205     $lockfile
1206 due to permission problems.
1207
1208 Please make sure that the configuration variable
1209     \$CPAN::Config->{cpan_home}
1210 points to a directory where you can write a .lock file. You can set
1211 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1212 \@INC path;
1213 });
1214                 return suggest_myconfig;
1215             }
1216         }
1217         my $sleep = 1;
1218         while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1219             if ($sleep>10) {
1220                 $CPAN::Frontend->mydie("Giving up\n");
1221             }
1222             $CPAN::Frontend->mysleep($sleep++);
1223             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1224         }
1225
1226         seek $fh, 0, 0;
1227         truncate $fh, 0;
1228         $fh->autoflush(1);
1229         $fh->print($$, "\n");
1230         $fh->print(hostname(), "\n");
1231         $self->{LOCK} = $lockfile;
1232         $self->{LOCKFH} = $fh;
1233     }
1234     $SIG{TERM} = sub {
1235         my $sig = shift;
1236         &cleanup;
1237         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1238     };
1239     $SIG{INT} = sub {
1240       # no blocks!!!
1241         my $sig = shift;
1242         &cleanup if $Signal;
1243         die "Got yet another signal" if $Signal > 1;
1244         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1245         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1246         $Signal++;
1247     };
1248
1249 #       From: Larry Wall <larry@wall.org>
1250 #       Subject: Re: deprecating SIGDIE
1251 #       To: perl5-porters@perl.org
1252 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1253 #
1254 #       The original intent of __DIE__ was only to allow you to substitute one
1255 #       kind of death for another on an application-wide basis without respect
1256 #       to whether you were in an eval or not.  As a global backstop, it should
1257 #       not be used any more lightly (or any more heavily :-) than class
1258 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1259 #       be politely squashed.  Any bug that causes every eval {} to have to be
1260 #       modified should be not so politely squashed.
1261 #
1262 #       Those are my current opinions.  It is also my optinion that polite
1263 #       arguments degenerate to personal arguments far too frequently, and that
1264 #       when they do, it's because both people wanted it to, or at least didn't
1265 #       sufficiently want it not to.
1266 #
1267 #       Larry
1268
1269     # global backstop to cleanup if we should really die
1270     $SIG{__DIE__} = \&cleanup;
1271     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1272 }
1273
1274 #-> sub CPAN::DESTROY ;
1275 sub DESTROY {
1276     &cleanup; # need an eval?
1277 }
1278
1279 #-> sub CPAN::anycwd ;
1280 sub anycwd () {
1281     my $getcwd;
1282     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1283     CPAN->$getcwd();
1284 }
1285
1286 #-> sub CPAN::cwd ;
1287 sub cwd {Cwd::cwd();}
1288
1289 #-> sub CPAN::getcwd ;
1290 sub getcwd {Cwd::getcwd();}
1291
1292 #-> sub CPAN::fastcwd ;
1293 sub fastcwd {Cwd::fastcwd();}
1294
1295 #-> sub CPAN::backtickcwd ;
1296 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1297
1298 #-> sub CPAN::find_perl ;
1299 sub find_perl () {
1300     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1301     unless ($perl) {
1302         my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
1303         $^X = $perl = $candidate if MM->maybe_command($candidate);
1304     }
1305     unless ($perl) {
1306         my ($component,$perl_name);
1307       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1308           PATH_COMPONENT: foreach $component (File::Spec->path(),
1309                                                 $Config::Config{'binexp'}) {
1310                 next unless defined($component) && $component;
1311                 my($abs) = File::Spec->catfile($component,$perl_name);
1312                 if (MM->maybe_command($abs)) {
1313                     $^X = $perl = $abs;
1314                     last DIST_PERLNAME;
1315                 }
1316             }
1317         }
1318     }
1319     return $perl;
1320 }
1321
1322
1323 #-> sub CPAN::exists ;
1324 sub exists {
1325     my($mgr,$class,$id) = @_;
1326     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1327     CPAN::Index->reload;
1328     ### Carp::croak "exists called without class argument" unless $class;
1329     $id ||= "";
1330     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1331     my $exists;
1332     if (CPAN::_sqlite_running) {
1333         $exists = (exists $META->{readonly}{$class}{$id} or
1334                    $CPAN::SQLite->set($class, $id));
1335     } else {
1336         $exists =  exists $META->{readonly}{$class}{$id};
1337     }
1338     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1339 }
1340
1341 #-> sub CPAN::delete ;
1342 sub delete {
1343   my($mgr,$class,$id) = @_;
1344   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1345   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1346 }
1347
1348 #-> sub CPAN::has_usable
1349 # has_inst is sometimes too optimistic, we should replace it with this
1350 # has_usable whenever a case is given
1351 sub has_usable {
1352     my($self,$mod,$message) = @_;
1353     return 1 if $HAS_USABLE->{$mod};
1354     my $has_inst = $self->has_inst($mod,$message);
1355     return unless $has_inst;
1356     my $usable;
1357     $usable = {
1358                LWP => [ # we frequently had "Can't locate object
1359                         # method "new" via package "LWP::UserAgent" at
1360                         # (eval 69) line 2006
1361                        sub {require LWP},
1362                        sub {require LWP::UserAgent},
1363                        sub {require HTTP::Request},
1364                        sub {require URI::URL},
1365                       ],
1366                'Net::FTP' => [
1367                             sub {require Net::FTP},
1368                             sub {require Net::Config},
1369                            ],
1370                'File::HomeDir' => [
1371                                    sub {require File::HomeDir;
1372                                         unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1373                                             for ("Will not use File::HomeDir, need 0.52\n") {
1374                                                 $CPAN::Frontend->mywarn($_);
1375                                                 die $_;
1376                                             }
1377                                         }
1378                                     },
1379                                   ],
1380                'Archive::Tar' => [
1381                                   sub {require Archive::Tar;
1382                                        unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1383                                             for ("Will not use Archive::Tar, need 1.00\n") {
1384                                                 $CPAN::Frontend->mywarn($_);
1385                                                 die $_;
1386                                             }
1387                                        }
1388                                   },
1389                                  ],
1390                'File::Temp' => [
1391                                 # XXX we should probably delete from
1392                                 # %INC too so we can load after we
1393                                 # installed a new enough version --
1394                                 # I'm not sure.
1395                                 sub {require File::Temp;
1396                                      unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1397                                          for ("Will not use File::Temp, need 0.16\n") {
1398                                                 $CPAN::Frontend->mywarn($_);
1399                                                 die $_;
1400                                          }
1401                                      }
1402                                 },
1403                                ]
1404               };
1405     if ($usable->{$mod}) {
1406         for my $c (0..$#{$usable->{$mod}}) {
1407             my $code = $usable->{$mod}[$c];
1408             my $ret = eval { &$code() };
1409             $ret = "" unless defined $ret;
1410             if ($@) {
1411                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1412                 return;
1413             }
1414         }
1415     }
1416     return $HAS_USABLE->{$mod} = 1;
1417 }
1418
1419 #-> sub CPAN::has_inst
1420 sub has_inst {
1421     my($self,$mod,$message) = @_;
1422     Carp::croak("CPAN->has_inst() called without an argument")
1423         unless defined $mod;
1424     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1425         keys %{$CPAN::Config->{dontload_hash}||{}},
1426             @{$CPAN::Config->{dontload_list}||[]};
1427     if (defined $message && $message eq "no"  # afair only used by Nox
1428         ||
1429         $dont{$mod}
1430        ) {
1431       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1432       return 0;
1433     }
1434     my $file = $mod;
1435     my $obj;
1436     $file =~ s|::|/|g;
1437     $file .= ".pm";
1438     if ($INC{$file}) {
1439         # checking %INC is wrong, because $INC{LWP} may be true
1440         # although $INC{"URI/URL.pm"} may have failed. But as
1441         # I really want to say "bla loaded OK", I have to somehow
1442         # cache results.
1443         ### warn "$file in %INC"; #debug
1444         return 1;
1445     } elsif (eval { require $file }) {
1446         # eval is good: if we haven't yet read the database it's
1447         # perfect and if we have installed the module in the meantime,
1448         # it tries again. The second require is only a NOOP returning
1449         # 1 if we had success, otherwise it's retrying
1450
1451         my $mtime = (stat $INC{$file})[9];
1452         # privileged files loaded by has_inst; Note: we use $mtime
1453         # as a proxy for a checksum.
1454         $CPAN::Shell::reload->{$file} = $mtime;
1455         my $v = eval "\$$mod\::VERSION";
1456         $v = $v ? " (v$v)" : "";
1457         CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1458         if ($mod eq "CPAN::WAIT") {
1459             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1460         }
1461         return 1;
1462     } elsif ($mod eq "Net::FTP") {
1463         $CPAN::Frontend->mywarn(qq{
1464   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1465   if you just type
1466       install Bundle::libnet
1467
1468 }) unless $Have_warned->{"Net::FTP"}++;
1469         $CPAN::Frontend->mysleep(3);
1470     } elsif ($mod eq "Digest::SHA") {
1471         if ($Have_warned->{"Digest::SHA"}++) {
1472             $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1473                                      qq{because Digest::SHA not installed.\n});
1474         } else {
1475             $CPAN::Frontend->mywarn(qq{
1476   CPAN: checksum security checks disabled because Digest::SHA not installed.
1477   Please consider installing the Digest::SHA module.
1478
1479 });
1480             $CPAN::Frontend->mysleep(2);
1481         }
1482     } elsif ($mod eq "Module::Signature") {
1483         # NOT prefs_lookup, we are not a distro
1484         my $check_sigs = $CPAN::Config->{check_sigs};
1485         if (not $check_sigs) {
1486             # they do not want us:-(
1487         } elsif (not $Have_warned->{"Module::Signature"}++) {
1488             # No point in complaining unless the user can
1489             # reasonably install and use it.
1490             if (eval { require Crypt::OpenPGP; 1 } ||
1491                 (
1492                  defined $CPAN::Config->{'gpg'}
1493                  &&
1494                  $CPAN::Config->{'gpg'} =~ /\S/
1495                 )
1496                ) {
1497                 $CPAN::Frontend->mywarn(qq{
1498   CPAN: Module::Signature security checks disabled because Module::Signature
1499   not installed.  Please consider installing the Module::Signature module.
1500   You may also need to be able to connect over the Internet to the public
1501   keyservers like pgp.mit.edu (port 11371).
1502
1503 });
1504                 $CPAN::Frontend->mysleep(2);
1505             }
1506         }
1507     } else {
1508         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1509     }
1510     return 0;
1511 }
1512
1513 #-> sub CPAN::instance ;
1514 sub instance {
1515     my($mgr,$class,$id) = @_;
1516     CPAN::Index->reload;
1517     $id ||= "";
1518     # unsafe meta access, ok?
1519     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1520     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1521 }
1522
1523 #-> sub CPAN::new ;
1524 sub new {
1525     bless {}, shift;
1526 }
1527
1528 #-> sub CPAN::cleanup ;
1529 sub cleanup {
1530   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1531   local $SIG{__DIE__} = '';
1532   my($message) = @_;
1533   my $i = 0;
1534   my $ineval = 0;
1535   my($subroutine);
1536   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1537       $ineval = 1, last if
1538         $subroutine eq '(eval)';
1539   }
1540   return if $ineval && !$CPAN::End;
1541   return unless defined $META->{LOCK};
1542   return unless -f $META->{LOCK};
1543   $META->savehist;
1544   close $META->{LOCKFH};
1545   unlink $META->{LOCK};
1546   # require Carp;
1547   # Carp::cluck("DEBUGGING");
1548   if ( $CPAN::CONFIG_DIRTY ) {
1549       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1550   }
1551   $CPAN::Frontend->myprint("Lockfile removed.\n");
1552 }
1553
1554 #-> sub CPAN::readhist
1555 sub readhist {
1556     my($self,$term,$histfile) = @_;
1557     my $histsize = $CPAN::Config->{'histsize'} || 100;
1558     $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1559     my($fh) = FileHandle->new;
1560     open $fh, "<$histfile" or return;
1561     local $/ = "\n";
1562     while (<$fh>) {
1563         chomp;
1564         $term->AddHistory($_);
1565     }
1566     close $fh;
1567 }
1568
1569 #-> sub CPAN::savehist
1570 sub savehist {
1571     my($self) = @_;
1572     my($histfile,$histsize);
1573     unless ($histfile = $CPAN::Config->{'histfile'}) {
1574         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1575         return;
1576     }
1577     $histsize = $CPAN::Config->{'histsize'} || 100;
1578     if ($CPAN::term) {
1579         unless ($CPAN::term->can("GetHistory")) {
1580             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1581             return;
1582         }
1583     } else {
1584         return;
1585     }
1586     my @h = $CPAN::term->GetHistory;
1587     splice @h, 0, @h-$histsize if @h>$histsize;
1588     my($fh) = FileHandle->new;
1589     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1590     local $\ = local $, = "\n";
1591     print $fh @h;
1592     close $fh;
1593 }
1594
1595 #-> sub CPAN::is_tested
1596 sub is_tested {
1597     my($self,$what,$when) = @_;
1598     unless ($what) {
1599         Carp::cluck("DEBUG: empty what");
1600         return;
1601     }
1602     $self->{is_tested}{$what} = $when;
1603 }
1604
1605 #-> sub CPAN::reset_tested
1606 # forget all distributions tested -- resets what gets included in PERL5LIB
1607 sub reset_tested {
1608     my ($self) = @_;
1609     $self->{is_tested} = {};
1610 }
1611
1612 #-> sub CPAN::is_installed
1613 # unsets the is_tested flag: as soon as the thing is installed, it is
1614 # not needed in set_perl5lib anymore
1615 sub is_installed {
1616     my($self,$what) = @_;
1617     delete $self->{is_tested}{$what};
1618 }
1619
1620 sub _list_sorted_descending_is_tested {
1621     my($self) = @_;
1622     sort
1623         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1624             keys %{$self->{is_tested}}
1625 }
1626
1627 #-> sub CPAN::set_perl5lib
1628 # Notes on max environment variable length:
1629 #   - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1630 {
1631 my $fh;
1632 sub set_perl5lib {
1633     my($self,$for) = @_;
1634     unless ($for) {
1635         (undef,undef,undef,$for) = caller(1);
1636         $for =~ s/.*://;
1637     }
1638     $self->{is_tested} ||= {};
1639     return unless %{$self->{is_tested}};
1640     my $env = $ENV{PERL5LIB};
1641     $env = $ENV{PERLLIB} unless defined $env;
1642     my @env;
1643     push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1644     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1645     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1646
1647     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1648     return if !@dirs;
1649
1650     if (@dirs < 12) {
1651         $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1652         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1653     } elsif (@dirs < 24 ) {
1654         my @d = map {my $cp = $_;
1655                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1656                      $cp
1657                  } @dirs;
1658         $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1659                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1660                                  "for '$for'\n"
1661                                 );
1662         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1663     } else {
1664         my $cnt = keys %{$self->{is_tested}};
1665         $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
1666                                  "$cnt build dirs to PERL5LIB; ".
1667                                  "for '$for'\n"
1668                                 );
1669         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1670     }
1671 }}
1672
1673 package CPAN::CacheMgr;
1674 use strict;
1675
1676 #-> sub CPAN::CacheMgr::as_string ;
1677 sub as_string {
1678     eval { require Data::Dumper };
1679     if ($@) {
1680         return shift->SUPER::as_string;
1681     } else {
1682         return Data::Dumper::Dumper(shift);
1683     }
1684 }
1685
1686 #-> sub CPAN::CacheMgr::cachesize ;
1687 sub cachesize {
1688     shift->{DU};
1689 }
1690
1691 #-> sub CPAN::CacheMgr::tidyup ;
1692 sub tidyup {
1693   my($self) = @_;
1694   return unless $CPAN::META->{LOCK};
1695   return unless -d $self->{ID};
1696   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1697   for my $current (0..$#toremove) {
1698     my $toremove = $toremove[$current];
1699     $CPAN::Frontend->myprint(sprintf(
1700                                      "DEL(%d/%d): %s \n",
1701                                      $current+1,
1702                                      scalar @toremove,
1703                                      $toremove,
1704                                     )
1705                             );
1706     return if $CPAN::Signal;
1707     $self->_clean_cache($toremove);
1708     return if $CPAN::Signal;
1709   }
1710 }
1711
1712 #-> sub CPAN::CacheMgr::dir ;
1713 sub dir {
1714     shift->{ID};
1715 }
1716
1717 #-> sub CPAN::CacheMgr::entries ;
1718 sub entries {
1719     my($self,$dir) = @_;
1720     return unless defined $dir;
1721     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1722     $dir ||= $self->{ID};
1723     my($cwd) = CPAN::anycwd();
1724     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1725     my $dh = DirHandle->new(File::Spec->curdir)
1726         or Carp::croak("Couldn't opendir $dir: $!");
1727     my(@entries);
1728     for ($dh->read) {
1729         next if $_ eq "." || $_ eq "..";
1730         if (-f $_) {
1731             push @entries, File::Spec->catfile($dir,$_);
1732         } elsif (-d _) {
1733             push @entries, File::Spec->catdir($dir,$_);
1734         } else {
1735             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1736         }
1737     }
1738     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1739     sort { -M $a <=> -M $b} @entries;
1740 }
1741
1742 #-> sub CPAN::CacheMgr::disk_usage ;
1743 sub disk_usage {
1744     my($self,$dir,$fast) = @_;
1745     return if exists $self->{SIZE}{$dir};
1746     return if $CPAN::Signal;
1747     my($Du) = 0;
1748     if (-e $dir) {
1749         if (-d $dir) {
1750             unless (-x $dir) {
1751                 unless (chmod 0755, $dir) {
1752                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1753                                             "permission to change the permission; cannot ".
1754                                             "estimate disk usage of '$dir'\n");
1755                     $CPAN::Frontend->mysleep(5);
1756                     return;
1757                 }
1758             }
1759         } elsif (-f $dir) {
1760             # nothing to say, no matter what the permissions
1761         }
1762     } else {
1763         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1764         return;
1765     }
1766     if ($fast) {
1767         $Du = 0; # placeholder
1768     } else {
1769         find(
1770              sub {
1771            $File::Find::prune++ if $CPAN::Signal;
1772            return if -l $_;
1773            if ($^O eq 'MacOS') {
1774              require Mac::Files;
1775              my $cat  = Mac::Files::FSpGetCatInfo($_);
1776              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1777            } else {
1778              if (-d _) {
1779                unless (-x _) {
1780                  unless (chmod 0755, $_) {
1781                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1782                                            "the permission to change the permission; ".
1783                                            "can only partially estimate disk usage ".
1784                                            "of '$_'\n");
1785                    $CPAN::Frontend->mysleep(5);
1786                    return;
1787                  }
1788                }
1789              } else {
1790                $Du += (-s _);
1791              }
1792            }
1793          },
1794          $dir
1795             );
1796     }
1797     return if $CPAN::Signal;
1798     $self->{SIZE}{$dir} = $Du/1024/1024;
1799     unshift @{$self->{FIFO}}, $dir;
1800     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1801     $self->{DU} += $Du/1024/1024;
1802     $self->{DU};
1803 }
1804
1805 #-> sub CPAN::CacheMgr::_clean_cache ;
1806 sub _clean_cache {
1807     my($self,$dir) = @_;
1808     return unless -e $dir;
1809     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1810             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1811         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1812                                 "will not remove\n");
1813         $CPAN::Frontend->mysleep(5);
1814         return;
1815     }
1816     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1817         if $CPAN::DEBUG;
1818     File::Path::rmtree($dir);
1819     my $id_deleted = 0;
1820     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1821         my $yaml_module = CPAN::_yaml_module;
1822         if ($CPAN::META->has_inst($yaml_module)) {
1823             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1824             if ($@) {
1825                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1826                 unlink "$dir.yml" or
1827                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1828                 return;
1829             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1830                 $CPAN::META->delete("CPAN::Distribution", $id);
1831
1832                 # XXX we should restore the state NOW, otherise this
1833                 # distro does not exist until we read an index. BUG ALERT(?)
1834
1835                 # $CPAN::Frontend->mywarn (" +++\n");
1836                 $id_deleted++;
1837             }
1838         }
1839         unlink "$dir.yml"; # may fail
1840         unless ($id_deleted) {
1841             CPAN->debug("no distro found associated with '$dir'");
1842         }
1843     }
1844     $self->{DU} -= $self->{SIZE}{$dir};
1845     delete $self->{SIZE}{$dir};
1846 }
1847
1848 #-> sub CPAN::CacheMgr::new ;
1849 sub new {
1850     my $class = shift;
1851     my $time = time;
1852     my($debug,$t2);
1853     $debug = "";
1854     my $self = {
1855         ID => $CPAN::Config->{build_dir},
1856         MAX => $CPAN::Config->{'build_cache'},
1857         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1858         DU => 0
1859     };
1860     File::Path::mkpath($self->{ID});
1861     my $dh = DirHandle->new($self->{ID});
1862     bless $self, $class;
1863     $self->scan_cache;
1864     $t2 = time;
1865     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1866     $time = $t2;
1867     CPAN->debug($debug) if $CPAN::DEBUG;
1868     $self;
1869 }
1870
1871 #-> sub CPAN::CacheMgr::scan_cache ;
1872 sub scan_cache {
1873     my $self = shift;
1874     return if $self->{SCAN} eq 'never';
1875     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1876         unless $self->{SCAN} eq 'atstart';
1877     return unless $CPAN::META->{LOCK};
1878     $CPAN::Frontend->myprint(
1879                              sprintf("Scanning cache %s for sizes\n",
1880                              $self->{ID}));
1881     my $e;
1882     my @entries = $self->entries($self->{ID});
1883     my $i = 0;
1884     my $painted = 0;
1885     for $e (@entries) {
1886         my $symbol = ".";
1887         if ($self->{DU} > $self->{MAX}) {
1888             $symbol = "-";
1889             $self->disk_usage($e,1);
1890         } else {
1891             $self->disk_usage($e);
1892         }
1893         $i++;
1894         while (($painted/76) < ($i/@entries)) {
1895             $CPAN::Frontend->myprint($symbol);
1896             $painted++;
1897         }
1898         return if $CPAN::Signal;
1899     }
1900     $CPAN::Frontend->myprint("DONE\n");
1901     $self->tidyup;
1902 }
1903
1904 package CPAN::Shell;
1905 use strict;
1906
1907 #-> sub CPAN::Shell::h ;
1908 sub h {
1909     my($class,$about) = @_;
1910     if (defined $about) {
1911         my $help;
1912         if (exists $Help->{$about}) {
1913             if (ref $Help->{$about}) { # aliases
1914                 $about = ${$Help->{$about}};
1915             }
1916             $help = $Help->{$about};
1917         } else {
1918             $help = "No help available";
1919         }
1920         $CPAN::Frontend->myprint("$about\: $help\n");
1921     } else {
1922         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1923         $CPAN::Frontend->myprint(qq{
1924 Display Information $filler (ver $CPAN::VERSION)
1925  command  argument          description
1926  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1927  i        WORD or /REGEXP/  about any of the above
1928  ls       AUTHOR or GLOB    about files in the author's directory
1929     (with WORD being a module, bundle or author name or a distribution
1930     name of the form AUTHOR/DISTRIBUTION)
1931
1932 Download, Test, Make, Install...
1933  get      download                     clean    make clean
1934  make     make (implies get)           look     open subshell in dist directory
1935  test     make test (implies make)     readme   display these README files
1936  install  make install (implies test)  perldoc  display POD documentation
1937
1938 Upgrade
1939  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1940  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1941
1942 Pragmas
1943  force  CMD    try hard to do command  fforce CMD    try harder
1944  notest CMD    skip testing
1945
1946 Other
1947  h,?           display this menu       ! perl-code   eval a perl command
1948  o conf [opt]  set and query options   q             quit the cpan shell
1949  reload cpan   load CPAN.pm again      reload index  load newer indices
1950  autobundle    Snapshot                recent        latest CPAN uploads});
1951 }
1952 }
1953
1954 *help = \&h;
1955
1956 #-> sub CPAN::Shell::a ;
1957 sub a {
1958   my($self,@arg) = @_;
1959   # authors are always UPPERCASE
1960   for (@arg) {
1961     $_ = uc $_ unless /=/;
1962   }
1963   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1964 }
1965
1966 #-> sub CPAN::Shell::globls ;
1967 sub globls {
1968     my($self,$s,$pragmas) = @_;
1969     # ls is really very different, but we had it once as an ordinary
1970     # command in the Shell (upto rev. 321) and we could not handle
1971     # force well then
1972     my(@accept,@preexpand);
1973     if ($s =~ /[\*\?\/]/) {
1974         if ($CPAN::META->has_inst("Text::Glob")) {
1975             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1976                 my $rau = Text::Glob::glob_to_regex(uc $au);
1977                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1978                       if $CPAN::DEBUG;
1979                 push @preexpand, map { $_->id . "/" . $pathglob }
1980                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1981             } else {
1982                 my $rau = Text::Glob::glob_to_regex(uc $s);
1983                 push @preexpand, map { $_->id }
1984                     CPAN::Shell->expand_by_method('CPAN::Author',
1985                                                   ['id'],
1986                                                   "/$rau/");
1987             }
1988         } else {
1989             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1990         }
1991     } else {
1992         push @preexpand, uc $s;
1993     }
1994     for (@preexpand) {
1995         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1996             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1997             next;
1998         }
1999         push @accept, $_;
2000     }
2001     my $silent = @accept>1;
2002     my $last_alpha = "";
2003     my @results;
2004     for my $a (@accept) {
2005         my($author,$pathglob);
2006         if ($a =~ m|(.*?)/(.*)|) {
2007             my $a2 = $1;
2008             $pathglob = $2;
2009             $author = CPAN::Shell->expand_by_method('CPAN::Author',
2010                                                     ['id'],
2011                                                     $a2)
2012                 or $CPAN::Frontend->mydie("No author found for $a2\n");
2013         } else {
2014             $author = CPAN::Shell->expand_by_method('CPAN::Author',
2015                                                     ['id'],
2016                                                     $a)
2017                 or $CPAN::Frontend->mydie("No author found for $a\n");
2018         }
2019         if ($silent) {
2020             my $alpha = substr $author->id, 0, 1;
2021             my $ad;
2022             if ($alpha eq $last_alpha) {
2023                 $ad = "";
2024             } else {
2025                 $ad = "[$alpha]";
2026                 $last_alpha = $alpha;
2027             }
2028             $CPAN::Frontend->myprint($ad);
2029         }
2030         for my $pragma (@$pragmas) {
2031             if ($author->can($pragma)) {
2032                 $author->$pragma();
2033             }
2034         }
2035         push @results, $author->ls($pathglob,$silent); # silent if
2036                                                        # more than one
2037                                                        # author
2038         for my $pragma (@$pragmas) {
2039             my $unpragma = "un$pragma";
2040             if ($author->can($unpragma)) {
2041                 $author->$unpragma();
2042             }
2043         }
2044     }
2045     @results;
2046 }
2047
2048 #-> sub CPAN::Shell::local_bundles ;
2049 sub local_bundles {
2050     my($self,@which) = @_;
2051     my($incdir,$bdir,$dh);
2052     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
2053         my @bbase = "Bundle";
2054         while (my $bbase = shift @bbase) {
2055             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
2056             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
2057             if ($dh = DirHandle->new($bdir)) { # may fail
2058                 my($entry);
2059                 for $entry ($dh->read) {
2060                     next if $entry =~ /^\./;
2061                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
2062                     if (-d File::Spec->catdir($bdir,$entry)) {
2063                         push @bbase, "$bbase\::$entry";
2064                     } else {
2065                         next unless $entry =~ s/\.pm(?!\n)\Z//;
2066                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
2067                     }
2068                 }
2069             }
2070         }
2071     }
2072 }
2073
2074 #-> sub CPAN::Shell::b ;
2075 sub b {
2076     my($self,@which) = @_;
2077     CPAN->debug("which[@which]") if $CPAN::DEBUG;
2078     $self->local_bundles;
2079     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
2080 }
2081
2082 #-> sub CPAN::Shell::d ;
2083 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
2084
2085 #-> sub CPAN::Shell::m ;
2086 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
2087     my $self = shift;
2088     $CPAN::Frontend->myprint($self->format_result('Module',@_));
2089 }
2090
2091 #-> sub CPAN::Shell::i ;
2092 sub i {
2093     my($self) = shift;
2094     my(@args) = @_;
2095     @args = '/./' unless @args;
2096     my(@result);
2097     for my $type (qw/Bundle Distribution Module/) {
2098         push @result, $self->expand($type,@args);
2099     }
2100     # Authors are always uppercase.
2101     push @result, $self->expand("Author", map { uc $_ } @args);
2102
2103     my $result = @result == 1 ?
2104         $result[0]->as_string :
2105             @result == 0 ?
2106                 "No objects found of any type for argument @args\n" :
2107                     join("",
2108                          (map {$_->as_glimpse} @result),
2109                          scalar @result, " items found\n",
2110                         );
2111     $CPAN::Frontend->myprint($result);
2112 }
2113
2114 #-> sub CPAN::Shell::o ;
2115
2116 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
2117 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
2118 # probably have been called 'set' and 'o debug' maybe 'set debug' or
2119 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
2120 sub o {
2121     my($self,$o_type,@o_what) = @_;
2122     $o_type ||= "";
2123     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2124     if ($o_type eq 'conf') {
2125         my($cfilter);
2126         ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2127         if (!@o_what or $cfilter) { # print all things, "o conf"
2128             $cfilter ||= "";
2129             my $qrfilter = eval 'qr/$cfilter/';
2130             my($k,$v);
2131             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2132             my @from;
2133             if (exists $INC{'CPAN/Config.pm'}) {
2134                 push @from, $INC{'CPAN/Config.pm'};
2135             }
2136             if (exists $INC{'CPAN/MyConfig.pm'}) {
2137                 push @from, $INC{'CPAN/MyConfig.pm'};
2138             }
2139             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2140             $CPAN::Frontend->myprint(":\n");
2141             for $k (sort keys %CPAN::HandleConfig::can) {
2142                 next unless $k =~ /$qrfilter/;
2143                 $v = $CPAN::HandleConfig::can{$k};
2144                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2145             }
2146             $CPAN::Frontend->myprint("\n");
2147             for $k (sort keys %CPAN::HandleConfig::keys) {
2148                 next unless $k =~ /$qrfilter/;
2149                 CPAN::HandleConfig->prettyprint($k);
2150             }
2151             $CPAN::Frontend->myprint("\n");
2152         } else {
2153             if (CPAN::HandleConfig->edit(@o_what)) {
2154             } else {
2155                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2156                                          qq{items\n\n});
2157             }
2158         }
2159     } elsif ($o_type eq 'debug') {
2160         my(%valid);
2161         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2162         if (@o_what) {
2163             while (@o_what) {
2164                 my($what) = shift @o_what;
2165                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2166                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2167                     next;
2168                 }
2169                 if ( exists $CPAN::DEBUG{$what} ) {
2170                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2171                 } elsif ($what =~ /^\d/) {
2172                     $CPAN::DEBUG = $what;
2173                 } elsif (lc $what eq 'all') {
2174                     my($max) = 0;
2175                     for (values %CPAN::DEBUG) {
2176                         $max += $_;
2177                     }
2178                     $CPAN::DEBUG = $max;
2179                 } else {
2180                     my($known) = 0;
2181                     for (keys %CPAN::DEBUG) {
2182                         next unless lc($_) eq lc($what);
2183                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2184                         $known = 1;
2185                     }
2186                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
2187                         unless $known;
2188                 }
2189             }
2190         } else {
2191             my $raw = "Valid options for debug are ".
2192                 join(", ",sort(keys %CPAN::DEBUG), 'all').
2193                      qq{ or a number. Completion works on the options. }.
2194                      qq{Case is ignored.};
2195             require Text::Wrap;
2196             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2197             $CPAN::Frontend->myprint("\n\n");
2198         }
2199         if ($CPAN::DEBUG) {
2200             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2201             my($k,$v);
2202             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2203                 $v = $CPAN::DEBUG{$k};
2204                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2205                     if $v & $CPAN::DEBUG;
2206             }
2207         } else {
2208             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2209         }
2210     } else {
2211         $CPAN::Frontend->myprint(qq{
2212 Known options:
2213   conf    set or get configuration variables
2214   debug   set or get debugging options
2215 });
2216     }
2217 }
2218
2219 # CPAN::Shell::paintdots_onreload
2220 sub paintdots_onreload {
2221     my($ref) = shift;
2222     sub {
2223         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2224             my($subr) = $1;
2225             ++$$ref;
2226             local($|) = 1;
2227             # $CPAN::Frontend->myprint(".($subr)");
2228             $CPAN::Frontend->myprint(".");
2229             if ($subr =~ /\bshell\b/i) {
2230                 # warn "debug[$_[0]]";
2231
2232                 # It would be nice if we could detect that a
2233                 # subroutine has actually changed, but for now we
2234                 # practically always set the GOTOSHELL global
2235
2236                 $CPAN::GOTOSHELL=1;
2237             }
2238             return;
2239         }
2240         warn @_;
2241     };
2242 }
2243
2244 #-> sub CPAN::Shell::hosts ;
2245 sub hosts {
2246     my($self) = @_;
2247     my $fullstats = CPAN::FTP->_ftp_statistics();
2248     my $history = $fullstats->{history} || [];
2249     my %S; # statistics
2250     while (my $last = pop @$history) {
2251         my $attempts = $last->{attempts} or next;
2252         my $start;
2253         if (@$attempts) {
2254             $start = $attempts->[-1]{start};
2255             if ($#$attempts > 0) {
2256                 for my $i (0..$#$attempts-1) {
2257                     my $url = $attempts->[$i]{url} or next;
2258                     $S{no}{$url}++;
2259                 }
2260             }
2261         } else {
2262             $start = $last->{start};
2263         }
2264         next unless $last->{thesiteurl}; # C-C? bad filenames?
2265         $S{start} = $start;
2266         $S{end} ||= $last->{end};
2267         my $dltime = $last->{end} - $start;
2268         my $dlsize = $last->{filesize} || 0;
2269         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2270         my $s = $S{ok}{$url} ||= {};
2271         $s->{n}++;
2272         $s->{dlsize} ||= 0;
2273         $s->{dlsize} += $dlsize/1024;
2274         $s->{dltime} ||= 0;
2275         $s->{dltime} += $dltime;
2276     }
2277     my $res;
2278     for my $url (keys %{$S{ok}}) {
2279         next if $S{ok}{$url}{dltime} == 0; # div by zero
2280         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2281                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2282                              $url,
2283                             ];
2284     }
2285     for my $url (keys %{$S{no}}) {
2286         push @{$res->{no}}, [$S{no}{$url},
2287                              $url,
2288                             ];
2289     }
2290     my $R = ""; # report
2291     if ($S{start} && $S{end}) {
2292         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2293         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2294     }
2295     if ($res->{ok} && @{$res->{ok}}) {
2296         $R .= sprintf "\nSuccessful downloads:
2297    N       kB  secs      kB/s url\n";
2298         my $i = 20;
2299         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2300             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2301             last if --$i<=0;
2302         }
2303     }
2304     if ($res->{no} && @{$res->{no}}) {
2305         $R .= sprintf "\nUnsuccessful downloads:\n";
2306         my $i = 20;
2307         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2308             $R .= sprintf "%4d %s\n", @$_;
2309             last if --$i<=0;
2310         }
2311     }
2312     $CPAN::Frontend->myprint($R);
2313 }
2314
2315 # here is where 'reload cpan' is done
2316 #-> sub CPAN::Shell::reload ;
2317 sub reload {
2318     my($self,$command,@arg) = @_;
2319     $command ||= "";
2320     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2321     if ($command =~ /^cpan$/i) {
2322         my $redef = 0;
2323         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2324         my $failed;
2325       MFILE: for my $f (@relo) {
2326             next unless exists $INC{$f};
2327             my $p = $f;
2328             $p =~ s/\.pm$//;
2329             $p =~ s|/|::|g;
2330             $CPAN::Frontend->myprint("($p");
2331             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2332             $self->_reload_this($f) or $failed++;
2333             my $v = eval "$p\::->VERSION";
2334             $CPAN::Frontend->myprint("v$v)");
2335         }
2336         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2337         if ($failed) {
2338             my $errors = $failed == 1 ? "error" : "errors";
2339             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2340                                     "this session.\n");
2341         }
2342     } elsif ($command =~ /^index$/i) {
2343       CPAN::Index->force_reload;
2344     } else {
2345       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2346 index    re-reads the index files\n});
2347     }
2348 }
2349
2350 # reload means only load again what we have loaded before
2351 #-> sub CPAN::Shell::_reload_this ;
2352 sub _reload_this {
2353     my($self,$f,$args) = @_;
2354     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2355     return 1 unless $INC{$f}; # we never loaded this, so we do not
2356                               # reload but say OK
2357     my $pwd = CPAN::anycwd();
2358     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2359     my($file);
2360     for my $inc (@INC) {
2361         $file = File::Spec->catfile($inc,split /\//, $f);
2362         last if -f $file;
2363         $file = "";
2364     }
2365     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2366     my @inc = @INC;
2367     unless ($file && -f $file) {
2368         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2369         $file = $INC{$f};
2370         unless (CPAN->has_inst("File::Basename")) {
2371             @inc = File::Basename::dirname($file);
2372         } else {
2373             # do we ever need this?
2374             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2375         }
2376     }
2377     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2378     unless (-f $file) {
2379         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2380         return;
2381     }
2382     my $mtime = (stat $file)[9];
2383     $reload->{$f} ||= -1;
2384     my $must_reload = $mtime != $reload->{$f};
2385     $args ||= {};
2386     $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2387     if ($must_reload) {
2388         my $fh = FileHandle->new($file) or
2389             $CPAN::Frontend->mydie("Could not open $file: $!");
2390         local($/);
2391         local $^W = 1;
2392         my $content = <$fh>;
2393         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2394             if $CPAN::DEBUG;
2395         delete $INC{$f};
2396         local @INC = @inc;
2397         eval "require '$f'";
2398         if ($@) {
2399             warn $@;
2400             return;
2401         }
2402         $reload->{$f} = $mtime;
2403     } else {
2404         $CPAN::Frontend->myprint("__unchanged__");
2405     }
2406     return 1;
2407 }
2408
2409 #-> sub CPAN::Shell::mkmyconfig ;
2410 sub mkmyconfig {
2411     my($self, $cpanpm, %args) = @_;
2412     require CPAN::FirstTime;
2413     my $home = CPAN::HandleConfig::home;
2414     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2415         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2416     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2417     CPAN::HandleConfig::require_myconfig_or_config;
2418     $CPAN::Config ||= {};
2419     $CPAN::Config = {
2420         %$CPAN::Config,
2421         build_dir           =>  undef,
2422         cpan_home           =>  undef,
2423         keep_source_where   =>  undef,
2424         histfile            =>  undef,
2425     };
2426     CPAN::FirstTime::init($cpanpm, %args);
2427 }
2428
2429 #-> sub CPAN::Shell::_binary_extensions ;
2430 sub _binary_extensions {
2431     my($self) = shift @_;
2432     my(@result,$module,%seen,%need,$headerdone);
2433     for $module ($self->expand('Module','/./')) {
2434         my $file  = $module->cpan_file;
2435         next if $file eq "N/A";
2436         next if $file =~ /^Contact Author/;
2437         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2438         next if $dist->isa_perl;
2439         next unless $module->xs_file;
2440         local($|) = 1;
2441         $CPAN::Frontend->myprint(".");
2442         push @result, $module;
2443     }
2444 #    print join " | ", @result;
2445     $CPAN::Frontend->myprint("\n");
2446     return @result;
2447 }
2448
2449 #-> sub CPAN::Shell::recompile ;
2450 sub recompile {
2451     my($self) = shift @_;
2452     my($module,@module,$cpan_file,%dist);
2453     @module = $self->_binary_extensions();
2454     for $module (@module) { # we force now and compile later, so we
2455                             # don't do it twice
2456         $cpan_file = $module->cpan_file;
2457         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2458         $pack->force;
2459         $dist{$cpan_file}++;
2460     }
2461     for $cpan_file (sort keys %dist) {
2462         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2463         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2464         $pack->install;
2465         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2466                            # stop a package from recompiling,
2467                            # e.g. IO-1.12 when we have perl5.003_10
2468     }
2469 }
2470
2471 #-> sub CPAN::Shell::scripts ;
2472 sub scripts {
2473     my($self, $arg) = @_;
2474     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2475
2476     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2477         unless ($CPAN::META->has_inst($req)) {
2478             $CPAN::Frontend->mywarn("  $req not available\n");
2479         }
2480     }
2481     my $p = HTML::LinkExtor->new();
2482     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2483     unless (-f $indexfile) {
2484         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2485     }
2486     $p->parse_file($indexfile);
2487     my @hrefs;
2488     my $qrarg;
2489     if ($arg =~ s|^/(.+)/$|$1|) {
2490         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2491     }
2492     for my $l ($p->links) {
2493         my $tag = shift @$l;
2494         next unless $tag eq "a";
2495         my %att = @$l;
2496         my $href = $att{href};
2497         next unless $href =~ s|^\.\./authors/id/./../||;
2498         if ($arg) {
2499             if ($qrarg) {
2500                 if ($href =~ $qrarg) {
2501                     push @hrefs, $href;
2502                 }
2503             } else {
2504                 if ($href =~ /\Q$arg\E/) {
2505                     push @hrefs, $href;
2506                 }
2507             }
2508         } else {
2509             push @hrefs, $href;
2510         }
2511     }
2512     # now filter for the latest version if there is more than one of a name
2513     my %stems;
2514     for (sort @hrefs) {
2515         my $href = $_;
2516         s/-v?\d.*//;
2517         my $stem = $_;
2518         $stems{$stem} ||= [];
2519         push @{$stems{$stem}}, $href;
2520     }
2521     for (sort keys %stems) {
2522         my $highest;
2523         if (@{$stems{$_}} > 1) {
2524             $highest = List::Util::reduce {
2525                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2526               } @{$stems{$_}};
2527         } else {
2528             $highest = $stems{$_}[0];
2529         }
2530         $CPAN::Frontend->myprint("$highest\n");
2531     }
2532 }
2533
2534 #-> sub CPAN::Shell::report ;
2535 sub report {
2536     my($self,@args) = @_;
2537     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2538         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2539     }
2540     local $CPAN::Config->{test_report} = 1;
2541     $self->force("test",@args); # force is there so that the test be
2542                                 # re-run (as documented)
2543 }
2544
2545 # compare with is_tested
2546 #-> sub CPAN::Shell::install_tested
2547 sub install_tested {
2548     my($self,@some) = @_;
2549     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2550         return if @some;
2551     CPAN::Index->reload;
2552
2553     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2554         my $yaml = "$b.yml";
2555         unless (-f $yaml) {
2556             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2557             next;
2558         }
2559         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2560         my $id = $yaml_content->[0]{distribution}{ID};
2561         unless ($id) {
2562             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2563             next;
2564         }
2565         my $do = CPAN::Shell->expandany($id);
2566         unless ($do) {
2567             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2568             next;
2569         }
2570         unless ($do->{build_dir}) {
2571             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2572             next;
2573         }
2574         unless ($do->{build_dir} eq $b) {
2575             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2576             next;
2577         }
2578         push @some, $do;
2579     }
2580
2581     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2582         return unless @some;
2583
2584     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2585     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2586         return unless @some;
2587
2588     # @some = grep { not $_->uptodate } @some;
2589     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2590     #     return unless @some;
2591
2592     CPAN->debug("some[@some]");
2593     for my $d (@some) {
2594         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2595         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2596         $CPAN::Frontend->mysleep(1);
2597         $self->install($d);
2598     }
2599 }
2600
2601 #-> sub CPAN::Shell::upgrade ;
2602 sub upgrade {
2603     my($self,@args) = @_;
2604     $self->install($self->r(@args));
2605 }
2606
2607 #-> sub CPAN::Shell::_u_r_common ;
2608 sub _u_r_common {
2609     my($self) = shift @_;
2610     my($what) = shift @_;
2611     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2612     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2613           $what && $what =~ /^[aru]$/;
2614     my(@args) = @_;
2615     @args = '/./' unless @args;
2616     my(@result,$module,%seen,%need,$headerdone,
2617        $version_undefs,$version_zeroes,
2618        @version_undefs,@version_zeroes);
2619     $version_undefs = $version_zeroes = 0;
2620     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2621     my @expand = $self->expand('Module',@args);
2622     if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
2623              # for metadata cache
2624         my $expand = scalar @expand;
2625         $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
2626     }
2627     my @sexpand;
2628     if ($] < 5.008) {
2629         # hard to believe that the more complex sorting can lead to
2630         # stack curruptions on older perl
2631         @sexpand = sort {$a->id cmp $b->id} @expand;
2632     } else {
2633         @sexpand = map {
2634             $_->[1]
2635         } sort {
2636             $b->[0] <=> $a->[0]
2637             ||
2638             $a->[1]{ID} cmp $b->[1]{ID},
2639         } map {
2640             [$_->_is_representative_module,
2641              $_
2642             ]
2643         } @expand;
2644     }
2645     if ($CPAN::DEBUG) {
2646         $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
2647         sleep 1;
2648     }
2649   MODULE: for $module (@sexpand) {
2650         my $file  = $module->cpan_file;
2651         next MODULE unless defined $file; # ??
2652         $file =~ s!^./../!!;
2653         my($latest) = $module->cpan_version;
2654         my($inst_file) = $module->inst_file;
2655         CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
2656         my($have);
2657         return if $CPAN::Signal;
2658         my($next_MODULE);
2659         eval { # version.pm involved!
2660             if ($inst_file) {
2661                 if ($what eq "a") {
2662                     $have = $module->inst_version;
2663                 } elsif ($what eq "r") {
2664                     $have = $module->inst_version;
2665                     local($^W) = 0;
2666                     if ($have eq "undef") {
2667                         $version_undefs++;
2668                         push @version_undefs, $module->as_glimpse;
2669                     } elsif (CPAN::Version->vcmp($have,0)==0) {
2670                         $version_zeroes++;
2671                         push @version_zeroes, $module->as_glimpse;
2672                     }
2673                     ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
2674                     # to be pedantic we should probably say:
2675                     #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2676                     # to catch the case where CPAN has a version 0 and we have a version undef
2677                 } elsif ($what eq "u") {
2678                     ++$next_MODULE;
2679                 }
2680             } else {
2681                 if ($what eq "a") {
2682                     ++$next_MODULE;
2683                 } elsif ($what eq "r") {
2684                     ++$next_MODULE;
2685                 } elsif ($what eq "u") {
2686                     $have = "-";
2687                 }
2688             }
2689         };
2690         next MODULE if $next_MODULE;
2691         if ($@) {
2692             $CPAN::Frontend->mywarn
2693                 (sprintf("Error while comparing cpan/installed versions of '%s':
2694 INST_FILE: %s
2695 INST_VERSION: %s %s
2696 CPAN_VERSION: %s %s
2697 ",
2698                          $module->id,
2699                          $inst_file || "",
2700                          (defined $have ? $have : "[UNDEFINED]"),
2701                          (ref $have ? ref $have : ""),
2702                          $latest,
2703                          (ref $latest ? ref $latest : ""),
2704                         ));
2705             next MODULE;
2706         }
2707         return if $CPAN::Signal; # this is sometimes lengthy
2708         $seen{$file} ||= 0;
2709         if ($what eq "a") {
2710             push @result, sprintf "%s %s\n", $module->id, $have;
2711         } elsif ($what eq "r") {
2712             push @result, $module->id;
2713             next MODULE if $seen{$file}++;
2714         } elsif ($what eq "u") {
2715             push @result, $module->id;
2716             next MODULE if $seen{$file}++;
2717             next MODULE if $file =~ /^Contact/;
2718         }
2719         unless ($headerdone++) {
2720             $CPAN::Frontend->myprint("\n");
2721             $CPAN::Frontend->myprint(sprintf(
2722                                              $sprintf,
2723                                              "",
2724                                              "Package namespace",
2725                                              "",
2726                                              "installed",
2727                                              "latest",
2728                                              "in CPAN file"
2729                                             ));
2730         }
2731         my $color_on = "";
2732         my $color_off = "";
2733         if (
2734             $COLOR_REGISTERED
2735             &&
2736             $CPAN::META->has_inst("Term::ANSIColor")
2737             &&
2738             $module->description
2739            ) {
2740             $color_on = Term::ANSIColor::color("green");
2741             $color_off = Term::ANSIColor::color("reset");
2742         }
2743         $CPAN::Frontend->myprint(sprintf $sprintf,
2744                                  $color_on,
2745                                  $module->id,
2746                                  $color_off,
2747                                  $have,
2748                                  $latest,
2749                                  $file);
2750         $need{$module->id}++;
2751     }
2752     unless (%need) {
2753         if ($what eq "u") {
2754             $CPAN::Frontend->myprint("No modules found for @args\n");
2755         } elsif ($what eq "r") {
2756             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2757         }
2758     }
2759     if ($what eq "r") {
2760         if ($version_zeroes) {
2761             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2762             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2763                                      qq{a version number of 0\n});
2764             if ($CPAN::Config->{show_zero_versions}) {
2765                 local $" = "\t";
2766                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2767                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2768                                          qq{to hide them)\n});
2769             } else {
2770                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2771                                          qq{to show them)\n});
2772             }
2773         }
2774         if ($version_undefs) {
2775             my $s_has = $version_undefs > 1 ? "s have" : " has";
2776             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2777                                      qq{parseable version number\n});
2778             if ($CPAN::Config->{show_unparsable_versions}) {
2779                 local $" = "\t";
2780                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2781                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2782                                          qq{to hide them)\n});
2783             } else {
2784                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2785                                          qq{to show them)\n});
2786             }
2787         }
2788     }
2789     @result;
2790 }
2791
2792 #-> sub CPAN::Shell::r ;
2793 sub r {
2794     shift->_u_r_common("r",@_);
2795 }
2796
2797 #-> sub CPAN::Shell::u ;
2798 sub u {
2799     shift->_u_r_common("u",@_);
2800 }
2801
2802 #-> sub CPAN::Shell::failed ;
2803 sub failed {
2804     my($self,$only_id,$silent) = @_;
2805     my @failed;
2806   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2807         my $failed = "";
2808       NAY: for my $nosayer ( # order matters!
2809                             "unwrapped",
2810                             "writemakefile",
2811                             "signature_verify",
2812                             "make",
2813                             "make_test",
2814                             "install",
2815                             "make_clean",
2816                            ) {
2817             next unless exists $d->{$nosayer};
2818             next unless defined $d->{$nosayer};
2819             next unless (
2820                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2821                          $d->{$nosayer}->failed :
2822                          $d->{$nosayer} =~ /^NO/
2823                         );
2824             next NAY if $only_id && $only_id != (
2825                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2826                                                  ?
2827                                                  $d->{$nosayer}->commandid
2828                                                  :
2829                                                  $CPAN::CurrentCommandId
2830                                                 );
2831             $failed = $nosayer;
2832             last;
2833         }
2834         next DIST unless $failed;
2835         my $id = $d->id;
2836         $id =~ s|^./../||;
2837         #$print .= sprintf(
2838         #                  "  %-45s: %s %s\n",
2839         push @failed,
2840             (
2841              UNIVERSAL::can($d->{$failed},"failed") ?
2842              [
2843               $d->{$failed}->commandid,
2844               $id,
2845               $failed,
2846               $d->{$failed}->text,
2847               $d->{$failed}{TIME}||0,
2848              ] :
2849              [
2850               1,
2851               $id,
2852               $failed,
2853               $d->{$failed},
2854               0,
2855              ]
2856             );
2857     }
2858     my $scope;
2859     if ($only_id) {
2860         $scope = "this command";
2861     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2862         $scope = "this or a previous session";
2863         # it might be nice to have a section for previous session and
2864         # a second for this
2865     } else {
2866         $scope = "this session";
2867     }
2868     if (@failed) {
2869         my $print;
2870         my $debug = 0;
2871         if ($debug) {
2872             $print = join "",
2873                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2874                     sort { $a->[0] <=> $b->[0] } @failed;
2875         } else {
2876             $print = join "",
2877                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2878                     sort {
2879                         $a->[0] <=> $b->[0]
2880                             ||
2881                                 $a->[4] <=> $b->[4]
2882                        } @failed;
2883         }
2884         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2885     } elsif (!$only_id || !$silent) {
2886         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2887     }
2888 }
2889
2890 # XXX intentionally undocumented because completely bogus, unportable,
2891 # useless, etc.
2892
2893 #-> sub CPAN::Shell::status ;
2894 sub status {
2895     my($self) = @_;
2896     require Devel::Size;
2897     my $ps = FileHandle->new;
2898     open $ps, "/proc/$$/status";
2899     my $vm = 0;
2900     while (<$ps>) {
2901         next unless /VmSize:\s+(\d+)/;
2902         $vm = $1;
2903         last;
2904     }
2905     $CPAN::Frontend->mywarn(sprintf(
2906                                     "%-27s %6d\n%-27s %6d\n",
2907                                     "vm",
2908                                     $vm,
2909                                     "CPAN::META",
2910                                     Devel::Size::total_size($CPAN::META)/1024,
2911                                    ));
2912     for my $k (sort keys %$CPAN::META) {
2913         next unless substr($k,0,4) eq "read";
2914         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2915         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2916             warn sprintf "  %-25s %6d (keys: %6d)\n",
2917                 $k2,
2918                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2919                           scalar keys %{$CPAN::META->{$k}{$k2}};
2920         }
2921     }
2922 }
2923
2924 # compare with install_tested
2925 #-> sub CPAN::Shell::is_tested
2926 sub is_tested {
2927     my($self) = @_;
2928     CPAN::Index->reload;
2929     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2930         my $time;
2931         if ($CPAN::META->{is_tested}{$b}) {
2932             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2933         } else {
2934             $time = scalar localtime;
2935             $time =~ s/\S/?/g;
2936         }
2937         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2938     }
2939 }
2940
2941 #-> sub CPAN::Shell::autobundle ;
2942 sub autobundle {
2943     my($self) = shift;
2944     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2945     my(@bundle) = $self->_u_r_common("a",@_);
2946     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2947     File::Path::mkpath($todir);
2948     unless (-d $todir) {
2949         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2950         return;
2951     }
2952     my($y,$m,$d) =  (localtime)[5,4,3];
2953     $y+=1900;
2954     $m++;
2955     my($c) = 0;
2956     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2957     my($to) = File::Spec->catfile($todir,"$me.pm");
2958     while (-f $to) {
2959         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2960         $to = File::Spec->catfile($todir,"$me.pm");
2961     }
2962     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2963     $fh->print(
2964                "package Bundle::$me;\n\n",
2965                "\$VERSION = '0.01';\n\n",
2966                "1;\n\n",
2967                "__END__\n\n",
2968                "=head1 NAME\n\n",
2969                "Bundle::$me - Snapshot of installation on ",
2970                $Config::Config{'myhostname'},
2971                " on ",
2972                scalar(localtime),
2973                "\n\n=head1 SYNOPSIS\n\n",
2974                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2975                "=head1 CONTENTS\n\n",
2976                join("\n", @bundle),
2977                "\n\n=head1 CONFIGURATION\n\n",
2978                Config->myconfig,
2979                "\n\n=head1 AUTHOR\n\n",
2980                "This Bundle has been generated automatically ",
2981                "by the autobundle routine in CPAN.pm.\n",
2982               );
2983     $fh->close;
2984     $CPAN::Frontend->myprint("\nWrote bundle file
2985     $to\n\n");
2986 }
2987
2988 #-> sub CPAN::Shell::expandany ;
2989 sub expandany {
2990     my($self,$s) = @_;
2991     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2992     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2993         $s = CPAN::Distribution->normalize($s);
2994         return $CPAN::META->instance('CPAN::Distribution',$s);
2995         # Distributions spring into existence, not expand
2996     } elsif ($s =~ m|^Bundle::|) {
2997         $self->local_bundles; # scanning so late for bundles seems
2998                               # both attractive and crumpy: always
2999                               # current state but easy to forget
3000                               # somewhere
3001         return $self->expand('Bundle',$s);
3002     } else {
3003         return $self->expand('Module',$s)
3004             if $CPAN::META->exists('CPAN::Module',$s);
3005     }
3006     return;
3007 }
3008
3009 #-> sub CPAN::Shell::expand ;
3010 sub expand {
3011     my $self = shift;
3012     my($type,@args) = @_;
3013     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
3014     my $class = "CPAN::$type";
3015     my $methods = ['id'];
3016     for my $meth (qw(name)) {
3017         next unless $class->can($meth);
3018         push @$methods, $meth;
3019     }
3020     $self->expand_by_method($class,$methods,@args);
3021 }
3022
3023 #-> sub CPAN::Shell::expand_by_method ;
3024 sub expand_by_method {
3025     my $self = shift;
3026     my($class,$methods,@args) = @_;
3027     my($arg,@m);
3028     for $arg (@args) {
3029         my($regex,$command);
3030         if ($arg =~ m|^/(.*)/$|) {
3031             $regex = $1;
3032 # FIXME:  there seem to be some ='s in the author data, which trigger
3033 #         a failure here.  This needs to be contemplated.
3034 #            } elsif ($arg =~ m/=/) {
3035 #                $command = 1;
3036         }
3037         my $obj;
3038         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
3039                     $class,
3040                     defined $regex ? $regex : "UNDEFINED",
3041                     defined $command ? $command : "UNDEFINED",
3042                    ) if $CPAN::DEBUG;
3043         if (defined $regex) {
3044             if (CPAN::_sqlite_running) {
3045                 CPAN::Index->reload;
3046                 $CPAN::SQLite->search($class, $regex);
3047             }
3048             for $obj (
3049                       $CPAN::META->all_objects($class)
3050                      ) {
3051                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
3052                     # BUG, we got an empty object somewhere
3053                     require Data::Dumper;
3054                     CPAN->debug(sprintf(
3055                                         "Bug in CPAN: Empty id on obj[%s][%s]",
3056                                         $obj,
3057                                         Data::Dumper::Dumper($obj)
3058                                        )) if $CPAN::DEBUG;
3059                     next;
3060                 }
3061                 for my $method (@$methods) {
3062                     my $match = eval {$obj->$method() =~ /$regex/i};
3063                     if ($@) {
3064                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
3065                         $err ||= $@; # if we were too restrictive above
3066                         $CPAN::Frontend->mydie("$err\n");
3067                     } elsif ($match) {
3068                         push @m, $obj;
3069                         last;
3070                     }
3071                 }
3072             }
3073         } elsif ($command) {
3074             die "equal sign in command disabled (immature interface), ".
3075                 "you can set
3076  ! \$CPAN::Shell::ADVANCED_QUERY=1
3077 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
3078 that may go away anytime.\n"
3079                     unless $ADVANCED_QUERY;
3080             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
3081             my($matchcrit) = $criterion =~ m/^~(.+)/;
3082             for my $self (
3083                           sort
3084                           {$a->id cmp $b->id}
3085                           $CPAN::META->all_objects($class)
3086                          ) {
3087                 my $lhs = $self->$method() or next; # () for 5.00503
3088                 if ($matchcrit) {
3089                     push @m, $self if $lhs =~ m/$matchcrit/;
3090                 } else {
3091                     push @m, $self if $lhs eq $criterion;
3092                 }
3093             }
3094         } else {
3095             my($xarg) = $arg;
3096             if ( $class eq 'CPAN::Bundle' ) {
3097                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
3098             } elsif ($class eq "CPAN::Distribution") {
3099                 $xarg = CPAN::Distribution->normalize($arg);
3100             } else {
3101                 $xarg =~ s/:+/::/g;
3102             }
3103             if ($CPAN::META->exists($class,$xarg)) {
3104                 $obj = $CPAN::META->instance($class,$xarg);
3105             } elsif ($CPAN::META->exists($class,$arg)) {
3106                 $obj = $CPAN::META->instance($class,$arg);
3107             } else {
3108                 next;
3109             }
3110             push @m, $obj;
3111         }
3112     }
3113     @m = sort {$a->id cmp $b->id} @m;
3114     if ( $CPAN::DEBUG ) {
3115         my $wantarray = wantarray;
3116         my $join_m = join ",", map {$_->id} @m;
3117         # $self->debug("wantarray[$wantarray]join_m[$join_m]");
3118         my $count = scalar @m;
3119         $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
3120     }
3121     return wantarray ? @m : $m[0];
3122 }
3123
3124 #-> sub CPAN::Shell::format_result ;
3125 sub format_result {
3126     my($self) = shift;
3127     my($type,@args) = @_;
3128     @args = '/./' unless @args;
3129     my(@result) = $self->expand($type,@args);
3130     my $result = @result == 1 ?
3131         $result[0]->as_string :
3132             @result == 0 ?
3133                 "No objects of type $type found for argument @args\n" :
3134                     join("",
3135                          (map {$_->as_glimpse} @result),
3136                          scalar @result, " items found\n",
3137                         );
3138     $result;
3139 }
3140
3141 #-> sub CPAN::Shell::report_fh ;
3142 {
3143     my $installation_report_fh;
3144     my $previously_noticed = 0;
3145
3146     sub report_fh {
3147         return $installation_report_fh if $installation_report_fh;
3148         if ($CPAN::META->has_usable("File::Temp")) {
3149             $installation_report_fh
3150                 = File::Temp->new(
3151                                   dir      => File::Spec->tmpdir,
3152                                   template => 'cpan_install_XXXX',
3153                                   suffix   => '.txt',
3154                                   unlink   => 0,
3155                                  );
3156         }
3157         unless ( $installation_report_fh ) {
3158             warn("Couldn't open installation report file; " .
3159                  "no report file will be generated."
3160                 ) unless $previously_noticed++;
3161         }
3162     }
3163 }
3164
3165
3166 # The only reason for this method is currently to have a reliable
3167 # debugging utility that reveals which output is going through which
3168 # channel. No, I don't like the colors ;-)
3169
3170 # to turn colordebugging on, write
3171 # cpan> o conf colorize_output 1
3172
3173 #-> sub CPAN::Shell::colorize_output ;
3174 {
3175     my $print_ornamented_have_warned = 0;
3176     sub colorize_output {
3177         my $colorize_output = $CPAN::Config->{colorize_output};
3178         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3179             unless ($print_ornamented_have_warned++) {
3180                 # no myprint/mywarn within myprint/mywarn!
3181                 warn "Colorize_output is set to true but Term::ANSIColor is not
3182 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3183             }
3184             $colorize_output = 0;
3185         }
3186         return $colorize_output;
3187     }
3188 }
3189
3190
3191 #-> sub CPAN::Shell::print_ornamented ;
3192 sub print_ornamented {
3193     my($self,$what,$ornament) = @_;
3194     return unless defined $what;
3195
3196     local $| = 1; # Flush immediately
3197     if ( $CPAN::Be_Silent ) {
3198         print {report_fh()} $what;
3199         return;
3200     }
3201     my $swhat = "$what"; # stringify if it is an object
3202     if ($CPAN::Config->{term_is_latin}) {
3203         # note: deprecated, need to switch to $LANG and $LC_*
3204         # courtesy jhi:
3205         $swhat
3206             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3207     }
3208     if ($self->colorize_output) {
3209         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3210             # if you want to have this configurable, please file a bugreport
3211             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3212         }
3213         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3214         if ($@) {
3215             print "Term::ANSIColor rejects color[$ornament]: $@\n
3216 Please choose a different color (Hint: try 'o conf init /color/')\n";
3217         }
3218         # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
3219         # $trailer construct. We want the newline be the last thing if
3220         # there is a newline at the end ensuring that the next line is
3221         # empty for other players
3222         my $trailer = "";
3223         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3224         print $color_on,
3225             $swhat,
3226                 Term::ANSIColor::color("reset"),
3227                       $trailer;
3228     } else {
3229         print $swhat;
3230     }
3231 }
3232
3233 #-> sub CPAN::Shell::myprint ;
3234
3235 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3236 # I think, we send everything to STDOUT and use print for normal/good
3237 # news and warn for news that need more attention. Yes, this is our
3238 # working contract for now.
3239 sub myprint {
3240     my($self,$what) = @_;
3241     $self->print_ornamented($what,
3242                             $CPAN::Config->{colorize_print}||'bold blue on_white',
3243                            );
3244 }
3245
3246 sub optprint {
3247     my($self,$category,$what) = @_;
3248     my $vname = $category . "_verbosity";
3249     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3250     if (!$CPAN::Config->{$vname}
3251         || $CPAN::Config->{$vname} =~ /^v/
3252        ) {
3253         $CPAN::Frontend->myprint($what);
3254     }
3255 }
3256
3257 #-> sub CPAN::Shell::myexit ;
3258 sub myexit {
3259     my($self,$what) = @_;
3260     $self->myprint($what);
3261     exit;
3262 }
3263
3264 #-> sub CPAN::Shell::mywarn ;
3265 sub mywarn {
3266     my($self,$what) = @_;
3267     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3268 }
3269
3270 # only to be used for shell commands
3271 #-> sub CPAN::Shell::mydie ;
3272 sub mydie {
3273     my($self,$what) = @_;
3274     $self->mywarn($what);
3275
3276     # If it is the shell, we want the following die to be silent,
3277     # but if it is not the shell, we would need a 'die $what'. We need
3278     # to take care that only shell commands use mydie. Is this
3279     # possible?
3280
3281     die "\n";
3282 }
3283
3284 # sub CPAN::Shell::colorable_makemaker_prompt ;
3285 sub colorable_makemaker_prompt {
3286     my($foo,$bar) = @_;
3287     if (CPAN::Shell->colorize_output) {
3288         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3289         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3290         print $color_on;
3291     }
3292     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3293     if (CPAN::Shell->colorize_output) {
3294         print Term::ANSIColor::color('reset');
3295     }
3296     return $ans;
3297 }
3298
3299 # use this only for unrecoverable errors!
3300 #-> sub CPAN::Shell::unrecoverable_error ;
3301 sub unrecoverable_error {
3302     my($self,$what) = @_;
3303     my @lines = split /\n/, $what;
3304     my $longest = 0;
3305     for my $l (@lines) {
3306         $longest = length $l if length $l > $longest;
3307     }
3308     $longest = 62 if $longest > 62;
3309     for my $l (@lines) {
3310         if ($l =~ /^\s*$/) {
3311             $l = "\n";
3312             next;
3313         }
3314         $l = "==> $l";
3315         if (length $l < 66) {
3316             $l = pack "A66 A*", $l, "<==";
3317         }
3318         $l .= "\n";
3319     }
3320     unshift @lines, "\n";
3321     $self->mydie(join "", @lines);
3322 }
3323
3324 #-> sub CPAN::Shell::mysleep ;
3325 sub mysleep {
3326     my($self, $sleep) = @_;
3327     if (CPAN->has_inst("Time::HiRes")) {
3328         Time::HiRes::sleep($sleep);
3329     } else {
3330         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3331     }
3332 }
3333
3334 #-> sub CPAN::Shell::setup_output ;
3335 sub setup_output {
3336     return if -t STDOUT;
3337     my $odef = select STDERR;
3338     $| = 1;
3339     select STDOUT;
3340     $| = 1;
3341     select $odef;
3342 }
3343
3344 #-> sub CPAN::Shell::rematein ;
3345 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3346 sub rematein {
3347     my $self = shift;
3348     my($meth,@some) = @_;
3349     my @pragma;
3350     while($meth =~ /^(ff?orce|notest)$/) {
3351         push @pragma, $meth;
3352         $meth = shift @some or
3353             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3354                                    "cannot continue");
3355     }
3356     setup_output();
3357     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3358
3359     # Here is the place to set "test_count" on all involved parties to
3360     # 0. We then can pass this counter on to the involved
3361     # distributions and those can refuse to test if test_count > X. In
3362     # the first stab at it we could use a 1 for "X".
3363
3364     # But when do I reset the distributions to start with 0 again?
3365     # Jost suggested to have a random or cycling interaction ID that
3366     # we pass through. But the ID is something that is just left lying
3367     # around in addition to the counter, so I'd prefer to set the
3368     # counter to 0 now, and repeat at the end of the loop. But what
3369     # about dependencies? They appear later and are not reset, they
3370     # enter the queue but not its copy. How do they get a sensible
3371     # test_count?
3372
3373     # With configure_requires, "get" is vulnerable in recursion.
3374
3375     my $needs_recursion_protection = "get|make|test|install";
3376
3377     # construct the queue
3378     my($s,@s,@qcopy);
3379   STHING: foreach $s (@some) {
3380         my $obj;
3381         if (ref $s) {
3382             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3383             $obj = $s;
3384         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3385         } elsif ($s =~ m|^/|) { # looks like a regexp
3386             if (substr($s,-1,1) eq ".") {
3387                 $obj = CPAN::Shell->expandany($s);
3388             } else {
3389                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3390                                         "not supported.\nRejecting argument '$s'\n");
3391                 $CPAN::Frontend->mysleep(2);
3392                 next;
3393             }
3394         } elsif ($meth eq "ls") {
3395             $self->globls($s,\@pragma);
3396             next STHING;
3397         } else {
3398             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3399             $obj = CPAN::Shell->expandany($s);
3400         }
3401         if (0) {
3402         } elsif (ref $obj) {
3403             if ($meth =~ /^($needs_recursion_protection)$/) {
3404                 # it would be silly to check for recursion for look or dump
3405                 # (we are in CPAN::Shell::rematein)
3406                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3407                 eval {  $obj->color_cmd_tmps(0,1); };
3408                 if ($@) {
3409                     if (ref $@
3410                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3411                         $CPAN::Frontend->mywarn($@);
3412                     } else {
3413                         if (0) {
3414                             require Carp;
3415                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3416                         }
3417                         die;
3418                     }
3419                 }
3420             }
3421             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3422             push @qcopy, $obj;
3423         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3424             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3425             if ($meth =~ /^(dump|ls|reports)$/) {
3426                 $obj->$meth();
3427             } else {
3428                 $CPAN::Frontend->mywarn(
3429                                         join "",
3430                                         "Don't be silly, you can't $meth ",
3431                                         $obj->fullname,
3432                                         " ;-)\n"
3433                                        );
3434                 $CPAN::Frontend->mysleep(2);
3435             }
3436         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3437             CPAN::InfoObj->dump($s);
3438         } else {
3439             $CPAN::Frontend
3440                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3441                          qq{don't know what it is.
3442 Try the command
3443
3444     i /$s/
3445
3446 to find objects with matching identifiers.
3447 });
3448             $CPAN::Frontend->mysleep(2);
3449         }
3450     }
3451
3452     # queuerunner (please be warned: when I started to change the
3453     # queue to hold objects instead of names, I made one or two
3454     # mistakes and never found which. I reverted back instead)
3455   QITEM: while (my $q = CPAN::Queue->first) {
3456         my $obj;
3457         my $s = $q->as_string;
3458         my $reqtype = $q->reqtype || "";
3459         $obj = CPAN::Shell->expandany($s);
3460         unless ($obj) {
3461             # don't know how this can happen, maybe we should panic,
3462             # but maybe we get a solution from the first user who hits
3463             # this unfortunate exception?
3464             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3465                                     "to an object. Skipping.\n");
3466             $CPAN::Frontend->mysleep(5);
3467             CPAN::Queue->delete_first($s);
3468             next QITEM;
3469         }
3470         $obj->{reqtype} ||= "";
3471         {
3472             # force debugging because CPAN::SQLite somehow delivers us
3473             # an empty object;
3474
3475             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3476
3477             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3478                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3479         }
3480         if ($obj->{reqtype}) {
3481             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3482                 $obj->{reqtype} = $reqtype;
3483                 if (
3484                     exists $obj->{install}
3485                     &&
3486                     (
3487                      UNIVERSAL::can($obj->{install},"failed") ?
3488                      $obj->{install}->failed :
3489                      $obj->{install} =~ /^NO/
3490                     )
3491                    ) {
3492                     delete $obj->{install};
3493                     $CPAN::Frontend->mywarn
3494                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3495                 }
3496             }
3497         } else {
3498             $obj->{reqtype} = $reqtype;
3499         }
3500
3501         for my $pragma (@pragma) {
3502             if ($pragma
3503                 &&
3504                 $obj->can($pragma)) {
3505                 $obj->$pragma($meth);
3506             }
3507         }
3508         if (UNIVERSAL::can($obj, 'called_for')) {
3509             $obj->called_for($s);
3510         }
3511         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3512                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3513
3514         push @qcopy, $obj;
3515         if ($meth =~ /^(report)$/) { # they came here with a pragma?
3516             $self->$meth($obj);
3517         } elsif (! UNIVERSAL::can($obj,$meth)) {
3518             # Must never happen
3519             my $serialized = "";
3520             if (0) {
3521             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3522                 $serialized = YAML::Syck::Dump($obj);
3523             } elsif ($CPAN::META->has_inst("YAML")) {
3524                 $serialized = YAML::Dump($obj);
3525             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3526                 $serialized = Data::Dumper::Dumper($obj);
3527             } else {
3528                 require overload;
3529                 $serialized = overload::StrVal($obj);
3530             }
3531             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3532             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3533         } elsif ($obj->$meth()) {
3534             CPAN::Queue->delete($s);
3535             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3536         } else {
3537             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3538         }
3539
3540         $obj->undelay;
3541         for my $pragma (@pragma) {
3542             my $unpragma = "un$pragma";
3543             if ($obj->can($unpragma)) {
3544                 $obj->$unpragma();
3545             }
3546         }
3547         if ($CPAN::Config->{halt_on_failure}
3548                 &&
3549                     CPAN::Distrostatus::something_has_just_failed()
3550               ) {
3551             $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
3552             CPAN::Queue->nullify_queue;
3553             last QITEM;
3554         }
3555         CPAN::Queue->delete_first($s);
3556     }
3557     if ($meth =~ /^($needs_recursion_protection)$/) {
3558         for my $obj (@qcopy) {
3559             $obj->color_cmd_tmps(0,0);
3560         }
3561     }
3562 }
3563
3564 #-> sub CPAN::Shell::recent ;
3565 sub recent {
3566   my($self) = @_;
3567   if ($CPAN::META->has_inst("XML::LibXML")) {
3568       my $url = $CPAN::Defaultrecent;
3569       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3570       unless ($CPAN::META->has_usable("LWP")) {
3571           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3572       }
3573       CPAN::LWP::UserAgent->config;
3574       my $Ua;
3575       eval { $Ua = CPAN::LWP::UserAgent->new; };
3576       if ($@) {
3577           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3578       }
3579       my $resp = $Ua->get($url);
3580       unless ($resp->is_success) {
3581           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3582       }
3583       $CPAN::Frontend->myprint("DONE\n\n");
3584       my $xml = XML::LibXML->new->parse_string($resp->content);
3585       if (0) {
3586           my $s = $xml->serialize(2);
3587           $s =~ s/\n\s*\n/\n/g;
3588           $CPAN::Frontend->myprint($s);
3589           return;
3590       }
3591       my @distros;
3592       if ($url =~ /winnipeg/) {
3593           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3594           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3595           for my $eitem ($xml->findnodes("/rss/channel/item")) {
3596               my $distro = $eitem->findvalue("enclosure/\@url");
3597               $distro =~ s|.*?/authors/id/./../||;
3598               my $size   = $eitem->findvalue("enclosure/\@length");
3599               my $desc   = $eitem->findvalue("description");
3600               $desc =~ s/.+? - //;
3601               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3602               push @distros, $distro;
3603           }
3604       } elsif ($url =~ /search.*uploads.rdf/) {
3605           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3606           # xmlns="http://purl.org/rss/1.0/"
3607           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3608           # xmlns:dc="http://purl.org/dc/elements/1.1/"
3609           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3610           # xmlns:admin="http://webns.net/mvcb/"
3611
3612
3613           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3614           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3615           my $finish_eitem = 0;
3616           local $SIG{INT} = sub { $finish_eitem = 1 };
3617         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3618               my $distro = $eitem->findvalue("\@rdf:about");
3619               $distro =~ s|.*~||; # remove up to the tilde before the name
3620               $distro =~ s|/$||; # remove trailing slash
3621               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3622               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3623               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3624               my $i = 0;
3625             SUBDIRTEST: while () {
3626                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3627                   if (my @ret = $self->globls("$distro*")) {
3628                       @ret = grep {$_->[2] !~ /meta/} @ret;
3629                       @ret = grep {length $_->[2]} @ret;
3630                       if (@ret) {
3631                           $distro = "$author/$ret[0][2]";
3632                           last SUBDIRTEST;
3633                       }
3634                   }
3635                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3636               }
3637
3638               next EITEM if $distro =~ m|\*|; # did not find the thing
3639               $CPAN::Frontend->myprint("____$desc\n");
3640               push @distros, $distro;
3641               last EITEM if $finish_eitem;
3642           }
3643       }
3644       return \@distros;
3645   } else {
3646       # deprecated old version
3647       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3648   }
3649 }
3650
3651 #-> sub CPAN::Shell::smoke ;
3652 sub smoke {
3653     my($self) = @_;
3654     my $distros = $self->recent;
3655   DISTRO: for my $distro (@$distros) {
3656         next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
3657         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3658         {
3659             my $skip = 0;
3660             local $SIG{INT} = sub { $skip = 1 };
3661             for (0..9) {
3662                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3663                 sleep 1;
3664                 if ($skip) {
3665                     $CPAN::Frontend->myprint(" skipped\n");
3666                     next DISTRO;
3667                 }
3668             }
3669         }
3670         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3671         $self->test($distro);
3672     }
3673 }
3674
3675 {
3676     # set up the dispatching methods
3677     no strict "refs";
3678     for my $command (qw(
3679                         clean
3680                         cvs_import
3681                         dump
3682                         force
3683                         fforce
3684                         get
3685                         install
3686                         look
3687                         ls
3688                         make
3689                         notest
3690                         perldoc
3691                         readme
3692                         reports
3693                         test
3694                        )) {
3695         *$command = sub { shift->rematein($command, @_); };
3696     }
3697 }
3698
3699 package CPAN::LWP::UserAgent;
3700 use strict;
3701
3702 sub config {
3703     return if $SETUPDONE;
3704     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3705         require LWP::UserAgent;
3706         @ISA = qw(Exporter LWP::UserAgent);
3707         $SETUPDONE++;
3708     } else {
3709         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3710     }
3711 }
3712
3713 sub get_basic_credentials {
3714     my($self, $realm, $uri, $proxy) = @_;
3715     if ($USER && $PASSWD) {
3716         return ($USER, $PASSWD);
3717     }
3718     if ( $proxy ) {
3719         ($USER,$PASSWD) = $self->get_proxy_credentials();
3720     } else {
3721         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3722     }
3723     return($USER,$PASSWD);
3724 }
3725
3726 sub get_proxy_credentials {
3727     my $self = shift;
3728     my ($user, $password);
3729     if ( defined $CPAN::Config->{proxy_user} ) {
3730         $user = $CPAN::Config->{proxy_user};
3731         $password = $CPAN::Config->{proxy_pass} || "";
3732         return ($user, $password);
3733     }
3734     my $username_prompt = "\nProxy authentication needed!
3735  (Note: to permanently configure username and password run
3736    o conf proxy_user your_username
3737    o conf proxy_pass your_password
3738      )\nUsername:";
3739     ($user, $password) =
3740         _get_username_and_password_from_user($username_prompt);
3741     return ($user,$password);
3742 }
3743
3744 sub get_non_proxy_credentials {
3745     my $self = shift;
3746     my ($user,$password);
3747     if ( defined $CPAN::Config->{username} ) {
3748         $user = $CPAN::Config->{username};
3749         $password = $CPAN::Config->{password} || "";
3750         return ($user, $password);
3751     }
3752     my $username_prompt = "\nAuthentication needed!
3753      (Note: to permanently configure username and password run
3754        o conf username your_username
3755        o conf password your_password
3756      )\nUsername:";
3757
3758     ($user, $password) =
3759         _get_username_and_password_from_user($username_prompt);
3760     return ($user,$password);
3761 }
3762
3763 sub _get_username_and_password_from_user {
3764     my $username_message = shift;
3765     my ($username,$password);
3766
3767     ExtUtils::MakeMaker->import(qw(prompt));
3768     $username = prompt($username_message);
3769         if ($CPAN::META->has_inst("Term::ReadKey")) {
3770             Term::ReadKey::ReadMode("noecho");
3771         }
3772     else {
3773         $CPAN::Frontend->mywarn(
3774             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3775         );
3776     }
3777     $password = prompt("Password:");
3778
3779         if ($CPAN::META->has_inst("Term::ReadKey")) {
3780             Term::ReadKey::ReadMode("restore");
3781         }
3782         $CPAN::Frontend->myprint("\n\n");
3783     return ($username,$password);
3784 }
3785
3786 # mirror(): Its purpose is to deal with proxy authentication. When we
3787 # call SUPER::mirror, we relly call the mirror method in
3788 # LWP::UserAgent. LWP::UserAgent will then call
3789 # $self->get_basic_credentials or some equivalent and this will be
3790 # $self->dispatched to our own get_basic_credentials method.
3791
3792 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3793
3794 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3795 # although we have gone through our get_basic_credentials, the proxy
3796 # server refuses to connect. This could be a case where the username or
3797 # password has changed in the meantime, so I'm trying once again without
3798 # $USER and $PASSWD to give the get_basic_credentials routine another
3799 # chance to set $USER and $PASSWD.
3800
3801 # mirror(): Its purpose is to deal with proxy authentication. When we
3802 # call SUPER::mirror, we relly call the mirror method in
3803 # LWP::UserAgent. LWP::UserAgent will then call
3804 # $self->get_basic_credentials or some equivalent and this will be
3805 # $self->dispatched to our own get_basic_credentials method.
3806
3807 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3808
3809 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3810 # although we have gone through our get_basic_credentials, the proxy
3811 # server refuses to connect. This could be a case where the username or
3812 # password has changed in the meantime, so I'm trying once again without
3813 # $USER and $PASSWD to give the get_basic_credentials routine another
3814 # chance to set $USER and $PASSWD.
3815
3816 sub mirror {
3817     my($self,$url,$aslocal) = @_;
3818     my $result = $self->SUPER::mirror($url,$aslocal);
3819     if ($result->code == 407) {
3820         undef $USER;
3821         undef $PASSWD;
3822         $result = $self->SUPER::mirror($url,$aslocal);
3823     }
3824     $result;
3825 }
3826
3827 package CPAN::FTP;
3828 use strict;
3829
3830 #-> sub CPAN::FTP::ftp_statistics
3831 # if they want to rewrite, they need to pass in a filehandle
3832 sub _ftp_statistics {
3833     my($self,$fh) = @_;
3834     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3835     $fh ||= FileHandle->new;
3836     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3837     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3838     my $sleep = 1;
3839     my $waitstart;
3840     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3841         $waitstart ||= localtime();
3842         if ($sleep>3) {
3843             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3844         }
3845         $CPAN::Frontend->mysleep($sleep);
3846         if ($sleep <= 3) {
3847             $sleep+=0.33;
3848         } elsif ($sleep <=6) {
3849             $sleep+=0.11;
3850         }
3851     }
3852     my $stats = eval { CPAN->_yaml_loadfile($file); };
3853     if ($@) {
3854         if (ref $@) {
3855             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3856                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3857                 return;
3858             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3859                 $CPAN::Frontend->mydie($@);
3860             }
3861         } else {
3862             $CPAN::Frontend->mydie($@);
3863         }
3864     }
3865     return $stats->[0];
3866 }
3867
3868 #-> sub CPAN::FTP::_mytime
3869 sub _mytime () {
3870     if (CPAN->has_inst("Time::HiRes")) {
3871         return Time::HiRes::time();
3872     } else {
3873         return time;
3874     }
3875 }
3876
3877 #-> sub CPAN::FTP::_new_stats
3878 sub _new_stats {
3879     my($self,$file) = @_;
3880     my $ret = {
3881                file => $file,
3882                attempts => [],
3883                start => _mytime,
3884               };
3885     $ret;
3886 }
3887
3888 #-> sub CPAN::FTP::_add_to_statistics
3889 sub _add_to_statistics {
3890     my($self,$stats) = @_;
3891     my $yaml_module = CPAN::_yaml_module;
3892     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3893     if ($CPAN::META->has_inst($yaml_module)) {
3894         $stats->{thesiteurl} = $ThesiteURL;
3895         $stats->{end} = CPAN::FTP::_mytime();
3896         my $fh = FileHandle->new;
3897         my $time = time;
3898         my $sdebug = 0;
3899         my @debug;
3900         @debug = $time if $sdebug;
3901         my $fullstats = $self->_ftp_statistics($fh);
3902         close $fh;
3903         $fullstats->{history} ||= [];
3904         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3905         push @debug, time if $sdebug;
3906         push @{$fullstats->{history}}, $stats;
3907         # YAML.pm 0.62 is unacceptably slow with 999;
3908         # YAML::Syck 0.82 has no noticable performance problem with 999;
3909         my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
3910         my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
3911         while (
3912                @{$fullstats->{history}} > $ftpstats_size
3913                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
3914               ) {
3915             shift @{$fullstats->{history}}
3916         }
3917         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3918         push @debug, time if $sdebug;
3919         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3920         # need no eval because if this fails, it is serious
3921         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3922         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3923         if ( $sdebug ) {
3924             local $CPAN::DEBUG = 512; # FTP
3925             push @debug, time;
3926             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3927                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3928                                 @debug,
3929                                ));
3930         }
3931         # Win32 cannot rename a file to an existing filename
3932         unlink($sfile) if ($^O eq 'MSWin32');
3933         _copy_stat($sfile, "$sfile.$$") if -e $sfile;
3934         rename "$sfile.$$", $sfile
3935             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3936     }
3937 }
3938
3939 # Copy some stat information (owner, group, mode and) from one file to
3940 # another.
3941 # This is a utility function which might be moved to a utility repository.
3942 #-> sub CPAN::FTP::_copy_stat
3943 sub _copy_stat {
3944     my($src, $dest) = @_;
3945     my @stat = stat($src);
3946     if (!@stat) {
3947         $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
3948         return;
3949     }
3950
3951     eval {
3952         chmod $stat[2], $dest
3953             or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
3954     };
3955     warn $@ if $@;
3956     eval {
3957         chown $stat[4], $stat[5], $dest
3958             or do {
3959                 my $save_err = $!; # otherwise it's lost in the get... calls
3960                 $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
3961                                         (getpwuid($stat[4]))[0] . "/" .
3962                                         (getgrgid($stat[5]))[0] . ": $save_err\n"
3963                                        );
3964             };
3965     };
3966     warn $@ if $@;
3967 }
3968
3969 # if file is CHECKSUMS, suggest the place where we got the file to be
3970 # checked from, maybe only for young files?
3971 #-> sub CPAN::FTP::_recommend_url_for
3972 sub _recommend_url_for {
3973     my($self, $file) = @_;
3974     my $urllist = $self->_get_urllist;
3975     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3976         my $fullstats = $self->_ftp_statistics();
3977         my $history = $fullstats->{history} || [];
3978         while (my $last = pop @$history) {
3979             last if $last->{end} - time > 3600; # only young results are interesting
3980             next unless $last->{file}; # dirname of nothing dies!
3981             next unless $file eq File::Basename::dirname($last->{file});
3982             return $last->{thesiteurl};
3983         }
3984     }
3985     if ($CPAN::Config->{randomize_urllist}
3986         &&
3987         rand(1) < $CPAN::Config->{randomize_urllist}
3988        ) {
3989         $urllist->[int rand scalar @$urllist];
3990     } else {
3991         return ();
3992     }
3993 }
3994
3995 #-> sub CPAN::FTP::_get_urllist
3996 sub _get_urllist {
3997     my($self) = @_;
3998     $CPAN::Config->{urllist} ||= [];
3999     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
4000         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
4001         $CPAN::Config->{urllist} = [];
4002     }
4003     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
4004     for my $u (@urllist) {
4005         CPAN->debug("u[$u]") if $CPAN::DEBUG;
4006         if (UNIVERSAL::can($u,"text")) {
4007             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
4008         } else {
4009             $u .= "/" unless substr($u,-1) eq "/";
4010             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
4011         }
4012     }
4013     \@urllist;
4014 }
4015
4016 #-> sub CPAN::FTP::ftp_get ;
4017 sub ftp_get {
4018     my($class,$host,$dir,$file,$target) = @_;
4019     $class->debug(
4020                   qq[Going to fetch file [$file] from dir [$dir]
4021         on host [$host] as local [$target]\n]
4022                  ) if $CPAN::DEBUG;
4023     my $ftp = Net::FTP->new($host);
4024     unless ($ftp) {
4025         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
4026         return;
4027     }
4028     return 0 unless defined $ftp;
4029     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
4030     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
4031     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
4032         my $msg = $ftp->message;
4033         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
4034         return;
4035     }
4036     unless ( $ftp->cwd($dir) ) {
4037         my $msg = $ftp->message;
4038         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
4039         return;
4040     }
4041     $ftp->binary;
4042     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
4043     unless ( $ftp->get($file,$target) ) {
4044         my $msg = $ftp->message;
4045         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
4046         return;
4047     }
4048     $ftp->quit; # it's ok if this fails
4049     return 1;
4050 }
4051
4052 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
4053
4054  # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
4055  # > --- /tmp/cp Wed Sep 24 13:26:40 1997
4056  # > ***************
4057  # > *** 1562,1567 ****
4058  # > --- 1562,1580 ----
4059  # >       return 1 if substr($url,0,4) eq "file";
4060  # >       return 1 unless $url =~ m|://([^/]+)|;
4061  # >       my $host = $1;
4062  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4063  # > +     if ($proxy) {
4064  # > +         $proxy =~ m|://([^/:]+)|;
4065  # > +         $proxy = $1;
4066  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
4067  # > +         if ($noproxy) {
4068  # > +             if ($host !~ /$noproxy$/) {
4069  # > +                 $host = $proxy;
4070  # > +             }
4071  # > +         } else {
4072  # > +             $host = $proxy;
4073  # > +         }
4074  # > +     }
4075  # >       require Net::Ping;
4076  # >       return 1 unless $Net::Ping::VERSION >= 2;
4077  # >       my $p;
4078
4079
4080 #-> sub CPAN::FTP::localize ;
4081 sub localize {
4082     my($self,$file,$aslocal,$force) = @_;
4083     $force ||= 0;
4084     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
4085         unless defined $aslocal;
4086     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
4087         if $CPAN::DEBUG;
4088
4089     if ($^O eq 'MacOS') {
4090         # Comment by AK on 2000-09-03: Uniq short filenames would be
4091         # available in CHECKSUMS file
4092         my($name, $path) = File::Basename::fileparse($aslocal, '');
4093         if (length($name) > 31) {
4094             $name =~ s/(
4095                         \.(
4096                            readme(\.(gz|Z))? |
4097                            (tar\.)?(gz|Z) |
4098                            tgz |
4099                            zip |
4100                            pm\.(gz|Z)
4101                           )
4102                        )$//x;
4103             my $suf = $1;
4104             my $size = 31 - length($suf);
4105             while (length($name) > $size) {
4106                 chop $name;
4107             }
4108             $name .= $suf;
4109             $aslocal = File::Spec->catfile($path, $name);
4110         }
4111     }
4112
4113     if (-f $aslocal && -r _ && !($force & 1)) {
4114         my $size;
4115         if ($size = -s $aslocal) {
4116             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
4117             return $aslocal;
4118         } else {
4119             # empty file from a previous unsuccessful attempt to download it
4120             unlink $aslocal or
4121                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
4122                                        "could not remove.");
4123         }
4124     }
4125     my($maybe_restore) = 0;
4126     if (-f $aslocal) {
4127         rename $aslocal, "$aslocal.bak$$";
4128         $maybe_restore++;
4129     }
4130
4131     my($aslocal_dir) = File::Basename::dirname($aslocal);
4132     $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
4133     # Inheritance is not easier to manage than a few if/else branches
4134     if ($CPAN::META->has_usable('LWP::UserAgent')) {
4135         unless ($Ua) {
4136             CPAN::LWP::UserAgent->config;
4137             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
4138             if ($@) {
4139                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
4140                     if $CPAN::DEBUG;
4141             } else {
4142                 my($var);
4143                 $Ua->proxy('ftp',  $var)
4144                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
4145                 $Ua->proxy('http', $var)
4146                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4147                 $Ua->no_proxy($var)
4148                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4149             }
4150         }
4151     }
4152     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
4153         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
4154     }
4155
4156     # Try the list of urls for each single object. We keep a record
4157     # where we did get a file from
4158     my(@reordered,$last);
4159     my $ccurllist = $self->_get_urllist;
4160     $last = $#$ccurllist;
4161     if ($force & 2) { # local cpans probably out of date, don't reorder
4162         @reordered = (0..$last);
4163     } else {
4164         @reordered =
4165             sort {
4166                 (substr($ccurllist->[$b],0,4) eq "file")
4167                     <=>
4168                 (substr($ccurllist->[$a],0,4) eq "file")
4169                     or
4170                 defined($ThesiteURL)
4171                     and
4172                 ($ccurllist->[$b] eq $ThesiteURL)
4173                     <=>
4174                 ($ccurllist->[$a] eq $ThesiteURL)
4175             } 0..$last;
4176     }
4177     my(@levels);
4178     $Themethod ||= "";
4179     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
4180     my @all_levels = (
4181                       ["dleasy",   "file"],
4182                       ["dleasy"],
4183                       ["dlhard"],
4184                       ["dlhardest"],
4185                       ["dleasy",   "http","defaultsites"],
4186                       ["dlhard",   "http","defaultsites"],
4187                       ["dleasy",   "ftp", "defaultsites"],
4188                       ["dlhard",   "ftp", "defaultsites"],
4189                       ["dlhardest","",    "defaultsites"],
4190                      );
4191     if ($Themethod) {
4192         @levels = grep {$_->[0] eq $Themethod} @all_levels;
4193         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4194     } else {
4195         @levels = @all_levels;
4196     }
4197     @levels = qw/dleasy/ if $^O eq 'MacOS';
4198     my($levelno);
4199     local $ENV{FTP_PASSIVE} =
4200         exists $CPAN::Config->{ftp_passive} ?
4201         $CPAN::Config->{ftp_passive} : 1;
4202     my $ret;
4203     my $stats = $self->_new_stats($file);
4204     for ($CPAN::Config->{connect_to_internet_ok}) {
4205         $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
4206     }
4207   LEVEL: for $levelno (0..$#levels) {
4208         my $level_tuple = $levels[$levelno];
4209         my($level,$scheme,$sitetag) = @$level_tuple;
4210         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4211         my @urllist;
4212         if ($defaultsites) {
4213             unless (defined $connect_to_internet_ok) {
4214                 $CPAN::Frontend->myprint(sprintf qq{
4215 I would like to connect to one of the following sites to get '%s':
4216
4217 %s
4218 },
4219                                          $file,
4220                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4221                                         );
4222                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4223                 if ($answer =~ /^y/i) {
4224                     $connect_to_internet_ok = 1;
4225                 } else {
4226                     $connect_to_internet_ok = 0;
4227                 }
4228             }
4229             if ($connect_to_internet_ok) {
4230                 @urllist = @CPAN::Defaultsites;
4231             } else {
4232                 @urllist = ();
4233             }
4234         } else {
4235             my @host_seq = $level =~ /dleasy/ ?
4236                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4237             @urllist = map { $ccurllist->[$_] } @host_seq;
4238         }
4239         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4240         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4241         if (my $recommend = $self->_recommend_url_for($file)) {
4242             @urllist = grep { $_ ne $recommend } @urllist;
4243             unshift @urllist, $recommend;
4244         }
4245         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4246         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4247         if ($ret) {
4248             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4249             if ($ret eq $aslocal_tempfile) {
4250                 # if we got it exactly as we asked for, only then we
4251                 # want to rename
4252                 rename $aslocal_tempfile, $aslocal
4253                     or $CPAN::Frontend->mydie("Error while trying to rename ".
4254                                               "'$ret' to '$aslocal': $!");
4255                 $ret = $aslocal;
4256             }
4257             $Themethod = $level;
4258             my $now = time;
4259             # utime $now, $now, $aslocal; # too bad, if we do that, we
4260                                           # might alter a local mirror
4261             $self->debug("level[$level]") if $CPAN::DEBUG;
4262             last LEVEL;
4263         } else {
4264             unlink $aslocal_tempfile;
4265             last if $CPAN::Signal; # need to cleanup
4266         }
4267     }
4268     if ($ret) {
4269         $stats->{filesize} = -s $ret;
4270     }
4271     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4272     $self->_add_to_statistics($stats);
4273     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4274     if ($ret) {
4275         unlink "$aslocal.bak$$";
4276         return $ret;
4277     }
4278     unless ($CPAN::Signal) {
4279         my(@mess);
4280         local $" = " ";
4281         if (@{$CPAN::Config->{urllist}}) {
4282             push @mess,
4283                 qq{Please check, if the URLs I found in your configuration file \(}.
4284                     join(", ", @{$CPAN::Config->{urllist}}).
4285                         qq{\) are valid.};
4286         } else {
4287             push @mess, qq{Your urllist is empty!};
4288         }
4289         push @mess, qq{The urllist can be edited.},
4290             qq{E.g. with 'o conf urllist push ftp://myurl/'};
4291         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4292         $CPAN::Frontend->mywarn("Could not fetch $file\n");
4293         $CPAN::Frontend->mysleep(2);
4294     }
4295     if ($maybe_restore) {
4296         rename "$aslocal.bak$$", $aslocal;
4297         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4298                                  $self->ls($aslocal));
4299         return $aslocal;
4300     }
4301     return;
4302 }
4303
4304 sub mymkpath {
4305     my($self, $aslocal_dir) = @_;
4306     File::Path::mkpath($aslocal_dir);
4307     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4308                             qq{directory "$aslocal_dir".
4309     I\'ll continue, but if you encounter problems, they may be due
4310     to insufficient permissions.\n}) unless -w $aslocal_dir;
4311 }
4312
4313 sub hostdlxxx {
4314     my $self = shift;
4315     my $level = shift;
4316     my $scheme = shift;
4317     my $h = shift;
4318     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4319     my $method = "host$level";
4320     $self->$method($h, @_);
4321 }
4322
4323 sub _set_attempt {
4324     my($self,$stats,$method,$url) = @_;
4325     push @{$stats->{attempts}}, {
4326                                  method => $method,
4327                                  start => _mytime,
4328                                  url => $url,
4329                                 };
4330 }
4331
4332 # package CPAN::FTP;
4333 sub hostdleasy {
4334     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4335     my($ro_url);
4336   HOSTEASY: for $ro_url (@$host_seq) {
4337         $self->_set_attempt($stats,"dleasy",$ro_url);
4338         my $url .= "$ro_url$file";
4339         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4340         if ($url =~ /^file:/) {
4341             my $l;
4342             if ($CPAN::META->has_inst('URI::URL')) {
4343                 my $u =  URI::URL->new($url);
4344                 $l = $u->path;
4345             } else { # works only on Unix, is poorly constructed, but
4346                 # hopefully better than nothing.
4347                 # RFC 1738 says fileurl BNF is
4348                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4349                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4350                 # the code
4351                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4352                 $l =~ s|^file:||;                   # assume they
4353                                                     # meant
4354                                                     # file://localhost
4355                 $l =~ s|^/||s
4356                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4357             }
4358             $self->debug("local file[$l]") if $CPAN::DEBUG;
4359             if ( -f $l && -r _) {
4360                 $ThesiteURL = $ro_url;
4361                 return $l;
4362             }
4363             if ($l =~ /(.+)\.gz$/) {
4364                 my $ungz = $1;
4365                 if ( -f $ungz && -r _) {
4366                     $ThesiteURL = $ro_url;
4367                     return $ungz;
4368                 }
4369             }
4370             # Maybe mirror has compressed it?
4371             if (-f "$l.gz") {
4372                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4373                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4374                 if ( -f $aslocal) {
4375                     $ThesiteURL = $ro_url;
4376                     return $aslocal;
4377                 }
4378             }
4379             $CPAN::Frontend->mywarn("Could not find '$l'\n");
4380         }
4381         $self->debug("it was not a file URL") if $CPAN::DEBUG;
4382         if ($CPAN::META->has_usable('LWP')) {
4383             $CPAN::Frontend->myprint("Fetching with LWP:
4384   $url
4385 ");
4386             unless ($Ua) {
4387                 CPAN::LWP::UserAgent->config;
4388                 eval { $Ua = CPAN::LWP::UserAgent->new; };
4389                 if ($@) {
4390                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4391                 }
4392             }
4393             my $res = $Ua->mirror($url, $aslocal);
4394             if ($res->is_success) {
4395                 $ThesiteURL = $ro_url;
4396                 my $now = time;
4397                 utime $now, $now, $aslocal; # download time is more
4398                                             # important than upload
4399                                             # time
4400                 return $aslocal;
4401             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4402                 my $gzurl = "$url.gz";
4403                 $CPAN::Frontend->myprint("Fetching with LWP:
4404   $gzurl
4405 ");
4406                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4407                 if ($res->is_success) {
4408                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4409                         $ThesiteURL = $ro_url;
4410                         return $aslocal;
4411                     }
4412                 }
4413             } else {
4414                 $CPAN::Frontend->myprint(sprintf(
4415                                                  "LWP failed with code[%s] message[%s]\n",
4416                                                  $res->code,
4417                                                  $res->message,
4418                                                 ));
4419                 # Alan Burlison informed me that in firewall environments
4420                 # Net::FTP can still succeed where LWP fails. So we do not
4421                 # skip Net::FTP anymore when LWP is available.
4422             }
4423         } else {
4424             $CPAN::Frontend->mywarn("  LWP not available\n");
4425         }
4426         return if $CPAN::Signal;
4427         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4428             # that's the nice and easy way thanks to Graham
4429             $self->debug("recognized ftp") if $CPAN::DEBUG;
4430             my($host,$dir,$getfile) = ($1,$2,$3);
4431             if ($CPAN::META->has_usable('Net::FTP')) {
4432                 $dir =~ s|/+|/|g;
4433                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4434   $url
4435 ");
4436                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4437                              "aslocal[$aslocal]") if $CPAN::DEBUG;
4438                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4439                     $ThesiteURL = $ro_url;
4440                     return $aslocal;
4441                 }
4442                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4443                     my $gz = "$aslocal.gz";
4444                     $CPAN::Frontend->myprint("Fetching with Net::FTP
4445   $url.gz
4446 ");
4447                     if (CPAN::FTP->ftp_get($host,
4448                                            $dir,
4449                                            "$getfile.gz",
4450                                            $gz) &&
4451                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4452                     ) {
4453                         $ThesiteURL = $ro_url;
4454                         return $aslocal;
4455                     }
4456                 }
4457                 # next HOSTEASY;
4458             } else {
4459                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4460             }
4461         }
4462         if (
4463             UNIVERSAL::can($ro_url,"text")
4464             and
4465             $ro_url->{FROM} eq "USER"
4466            ) {
4467             ##address #17973: default URLs should not try to override
4468             ##user-defined URLs just because LWP is not available
4469             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4470             return $ret if $ret;
4471         }
4472         return if $CPAN::Signal;
4473     }
4474 }
4475
4476 # package CPAN::FTP;
4477 sub hostdlhard {
4478     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4479
4480     # Came back if Net::FTP couldn't establish connection (or
4481     # failed otherwise) Maybe they are behind a firewall, but they
4482     # gave us a socksified (or other) ftp program...
4483
4484     my($ro_url);
4485     my($devnull) = $CPAN::Config->{devnull} || "";
4486     # < /dev/null ";
4487     my($aslocal_dir) = File::Basename::dirname($aslocal);
4488     File::Path::mkpath($aslocal_dir);
4489   HOSTHARD: for $ro_url (@$host_seq) {
4490         $self->_set_attempt($stats,"dlhard",$ro_url);
4491         my $url = "$ro_url$file";
4492         my($proto,$host,$dir,$getfile);
4493
4494         # Courtesy Mark Conty mark_conty@cargill.com change from
4495         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4496         # to
4497         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4498             # proto not yet used
4499             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4500         } else {
4501             next HOSTHARD; # who said, we could ftp anything except ftp?
4502         }
4503         next HOSTHARD if $proto eq "file"; # file URLs would have had
4504                                            # success above. Likely a bogus URL
4505
4506         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4507
4508         # Try the most capable first and leave ncftp* for last as it only
4509         # does FTP.
4510         my $proxy_vars = $self->_proxy_vars($ro_url);
4511       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4512             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4513             next unless defined $funkyftp;
4514             next if $funkyftp =~ /^\s*$/;
4515
4516             my($asl_ungz, $asl_gz);
4517             ($asl_ungz = $aslocal) =~ s/\.gz//;
4518                 $asl_gz = "$asl_ungz.gz";
4519
4520             my($src_switch) = "";
4521             my($chdir) = "";
4522             my($stdout_redir) = " > $asl_ungz";
4523             if ($f eq "lynx") {
4524                 $src_switch = " -source";
4525             } elsif ($f eq "ncftp") {
4526                 $src_switch = " -c";
4527             } elsif ($f eq "wget") {
4528                 $src_switch = " -O $asl_ungz";
4529                 $stdout_redir = "";
4530             } elsif ($f eq 'curl') {
4531                 $src_switch = ' -L -f -s -S --netrc-optional';
4532                 if ($proxy_vars->{http_proxy}) {
4533                     $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
4534                 }
4535             }
4536
4537             if ($f eq "ncftpget") {
4538                 $chdir = "cd $aslocal_dir && ";
4539                 $stdout_redir = "";
4540             }
4541             $CPAN::Frontend->myprint(
4542                                      qq[
4543 Trying with "$funkyftp$src_switch" to get
4544     $url
4545 ]);
4546             my($system) =
4547                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4548             $self->debug("system[$system]") if $CPAN::DEBUG;
4549             my($wstatus) = system($system);
4550             if ($f eq "lynx") {
4551                 # lynx returns 0 when it fails somewhere
4552                 if (-s $asl_ungz) {
4553                     my $content = do { local *FH;
4554                                        open FH, $asl_ungz or die;
4555                                        local $/;
4556                                        <FH> };
4557                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4558                         $CPAN::Frontend->mywarn(qq{
4559 No success, the file that lynx has downloaded looks like an error message:
4560 $content
4561 });
4562                         $CPAN::Frontend->mysleep(1);
4563                         next DLPRG;
4564                     }
4565                 } else {
4566                     $CPAN::Frontend->myprint(qq{
4567 No success, the file that lynx has downloaded is an empty file.
4568 });
4569                     next DLPRG;
4570                 }
4571             }
4572             if ($wstatus == 0) {
4573                 if (-s $aslocal) {
4574                     # Looks good
4575                 } elsif ($asl_ungz ne $aslocal) {
4576                     # test gzip integrity
4577                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4578                         # e.g. foo.tar is gzipped --> foo.tar.gz
4579                         rename $asl_ungz, $aslocal;
4580                     } else {
4581                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4582                     }
4583                 }
4584                 $ThesiteURL = $ro_url;
4585                 return $aslocal;
4586             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4587                 unlink $asl_ungz if
4588                     -f $asl_ungz && -s _ == 0;
4589                 my $gz = "$aslocal.gz";
4590                 my $gzurl = "$url.gz";
4591                 $CPAN::Frontend->myprint(
4592                                         qq[
4593     Trying with "$funkyftp$src_switch" to get
4594     $url.gz
4595     ]);
4596                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4597                 $self->debug("system[$system]") if $CPAN::DEBUG;
4598                 my($wstatus);
4599                 if (($wstatus = system($system)) == 0
4600                     &&
4601                     -s $asl_gz
4602                 ) {
4603                     # test gzip integrity
4604                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4605                     if ($ct && $ct->gtest) {
4606                         $ct->gunzip($aslocal);
4607                     } else {
4608                         # somebody uncompressed file for us?
4609                         rename $asl_ungz, $aslocal;
4610                     }
4611                     $ThesiteURL = $ro_url;
4612                     return $aslocal;
4613                 } else {
4614                     unlink $asl_gz if -f $asl_gz;
4615                 }
4616             } else {
4617                 my $estatus = $wstatus >> 8;
4618                 my $size = -f $aslocal ?
4619                     ", left\n$aslocal with size ".-s _ :
4620                     "\nWarning: expected file [$aslocal] doesn't exist";
4621                 $CPAN::Frontend->myprint(qq{
4622     System call "$system"
4623     returned status $estatus (wstat $wstatus)$size
4624     });
4625             }
4626             return if $CPAN::Signal;
4627         } # transfer programs
4628     } # host
4629 }
4630
4631 #-> CPAN::FTP::_proxy_vars
4632 sub _proxy_vars {
4633     my($self,$url) = @_;
4634     my $ret = +{};
4635     my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4636     if ($http_proxy) {
4637         my($host) = $url =~ m|://([^/:]+)|;
4638         my $want_proxy = 1;
4639         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
4640         my @noproxy = split /\s*,\s*/, $noproxy;
4641         if ($host) {
4642           DOMAIN: for my $domain (@noproxy) {
4643                 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
4644                     $want_proxy = 0;
4645                     last DOMAIN;
4646                 }
4647             }
4648         } else {
4649             $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
4650         }
4651         if ($want_proxy) {
4652             my($user, $pass) =
4653                 &CPAN::LWP::UserAgent::get_proxy_credentials();
4654             $ret = {
4655                     proxy_user => $user,
4656                     proxy_pass => $pass,
4657                     http_proxy => $http_proxy
4658                   };
4659         }
4660     }
4661     return $ret;
4662 }
4663
4664 # package CPAN::FTP;
4665 sub hostdlhardest {
4666     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4667
4668     return unless @$host_seq;
4669     my($ro_url);
4670     my($aslocal_dir) = File::Basename::dirname($aslocal);
4671     File::Path::mkpath($aslocal_dir);
4672     my $ftpbin = $CPAN::Config->{ftp};
4673     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4674         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4675         return;
4676     }
4677     $CPAN::Frontend->mywarn(qq{
4678 As a last ressort we now switch to the external ftp command '$ftpbin'
4679 to get '$aslocal'.
4680
4681 Doing so often leads to problems that are hard to diagnose.
4682
4683 If you're victim of such problems, please consider unsetting the ftp
4684 config variable with
4685
4686     o conf ftp ""
4687     o conf commit
4688
4689 });
4690     $CPAN::Frontend->mysleep(2);
4691   HOSTHARDEST: for $ro_url (@$host_seq) {
4692         $self->_set_attempt($stats,"dlhardest",$ro_url);
4693         my $url = "$ro_url$file";
4694         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4695         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4696             next;
4697         }
4698         my($host,$dir,$getfile) = ($1,$2,$3);
4699         my $timestamp = 0;
4700         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4701             $ctime,$blksize,$blocks) = stat($aslocal);
4702         $timestamp = $mtime ||= 0;
4703         my($netrc) = CPAN::FTP::netrc->new;
4704         my($netrcfile) = $netrc->netrc;
4705         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4706         my $targetfile = File::Basename::basename($aslocal);
4707         my(@dialog);
4708         push(
4709              @dialog,
4710              "lcd $aslocal_dir",
4711              "cd /",
4712              map("cd $_", split /\//, $dir), # RFC 1738
4713              "bin",
4714              "get $getfile $targetfile",
4715              "quit"
4716         );
4717         if (! $netrcfile) {
4718             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4719         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4720             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4721                                 $netrc->hasdefault,
4722                                 $netrc->contains($host))) if $CPAN::DEBUG;
4723             if ($netrc->protected) {
4724                 my $dialog = join "", map { "    $_\n" } @dialog;
4725                 my $netrc_explain;
4726                 if ($netrc->contains($host)) {
4727                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4728                         "manages the login";
4729                 } else {
4730                     $netrc_explain = "Relying that your default .netrc entry ".
4731                         "manages the login";
4732                 }
4733                 $CPAN::Frontend->myprint(qq{
4734   Trying with external ftp to get
4735     $url
4736   $netrc_explain
4737   Going to send the dialog
4738 $dialog
4739 }
4740                 );
4741                 $self->talk_ftp("$ftpbin$verbose $host",
4742                                 @dialog);
4743                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4744                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4745                 $mtime ||= 0;
4746                 if ($mtime > $timestamp) {
4747                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4748                     $ThesiteURL = $ro_url;
4749                     return $aslocal;
4750                 } else {
4751                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4752                 }
4753                     return if $CPAN::Signal;
4754             } else {
4755                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4756                                         qq{correctly protected.\n});
4757             }
4758         } else {
4759             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4760   nor does it have a default entry\n");
4761         }
4762
4763         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4764         # then and login manually to host, using e-mail as
4765         # password.
4766         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4767         unshift(
4768                 @dialog,
4769                 "open $host",
4770                 "user anonymous $Config::Config{'cf_email'}"
4771         );
4772         my $dialog = join "", map { "    $_\n" } @dialog;
4773         $CPAN::Frontend->myprint(qq{
4774   Trying with external ftp to get
4775     $url
4776   Going to send the dialog
4777 $dialog
4778 }
4779         );
4780         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4781         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4782             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4783         $mtime ||= 0;
4784         if ($mtime > $timestamp) {
4785             $CPAN::Frontend->myprint("GOT $aslocal\n");
4786             $ThesiteURL = $ro_url;
4787             return $aslocal;
4788         } else {
4789             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4790         }
4791         return if $CPAN::Signal;
4792         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4793         $CPAN::Frontend->mysleep(2);
4794     } # host
4795 }
4796
4797 # package CPAN::FTP;
4798 sub talk_ftp {
4799     my($self,$command,@dialog) = @_;
4800     my $fh = FileHandle->new;
4801     $fh->open("|$command") or die "Couldn't open ftp: $!";
4802     foreach (@dialog) { $fh->print("$_\n") }
4803     $fh->close; # Wait for process to complete
4804     my $wstatus = $?;
4805     my $estatus = $wstatus >> 8;
4806     $CPAN::Frontend->myprint(qq{
4807 Subprocess "|$command"
4808   returned status $estatus (wstat $wstatus)
4809 }) if $wstatus;
4810 }
4811
4812 # find2perl needs modularization, too, all the following is stolen
4813 # from there
4814 # CPAN::FTP::ls
4815 sub ls {
4816     my($self,$name) = @_;
4817     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4818      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4819
4820     my($perms,%user,%group);
4821     my $pname = $name;
4822
4823     if ($blocks) {
4824         $blocks = int(($blocks + 1) / 2);
4825     }
4826     else {
4827         $blocks = int(($sizemm + 1023) / 1024);
4828     }
4829
4830     if    (-f _) { $perms = '-'; }
4831     elsif (-d _) { $perms = 'd'; }
4832     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4833     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4834     elsif (-p _) { $perms = 'p'; }
4835     elsif (-S _) { $perms = 's'; }
4836     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4837
4838     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4839     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4840     my $tmpmode = $mode;
4841     my $tmp = $rwx[$tmpmode & 7];
4842     $tmpmode >>= 3;
4843     $tmp = $rwx[$tmpmode & 7] . $tmp;
4844     $tmpmode >>= 3;
4845     $tmp = $rwx[$tmpmode & 7] . $tmp;
4846     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4847     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4848     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4849     $perms .= $tmp;
4850
4851     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4852     my $group = $group{$gid} || $gid;
4853
4854     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4855     my($timeyear);
4856     my($moname) = $moname[$mon];
4857     if (-M _ > 365.25 / 2) {
4858         $timeyear = $year + 1900;
4859     }
4860     else {
4861         $timeyear = sprintf("%02d:%02d", $hour, $min);
4862     }
4863
4864     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4865              $ino,
4866                   $blocks,
4867                        $perms,
4868                              $nlink,
4869                                  $user,
4870                                       $group,
4871                                            $sizemm,
4872                                                $moname,
4873                                                   $mday,
4874                                                       $timeyear,
4875                                                           $pname;
4876 }
4877
4878 package CPAN::FTP::netrc;
4879 use strict;
4880
4881 # package CPAN::FTP::netrc;
4882 sub new {
4883     my($class) = @_;
4884     my $home = CPAN::HandleConfig::home;
4885     my $file = File::Spec->catfile($home,".netrc");
4886
4887     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4888        $atime,$mtime,$ctime,$blksize,$blocks)
4889         = stat($file);
4890     $mode ||= 0;
4891     my $protected = 0;
4892
4893     my($fh,@machines,$hasdefault);
4894     $hasdefault = 0;
4895     $fh = FileHandle->new or die "Could not create a filehandle";
4896
4897     if($fh->open($file)) {
4898         $protected = ($mode & 077) == 0;
4899         local($/) = "";
4900       NETRC: while (<$fh>) {
4901             my(@tokens) = split " ", $_;
4902           TOKEN: while (@tokens) {
4903                 my($t) = shift @tokens;
4904                 if ($t eq "default") {
4905                     $hasdefault++;
4906                     last NETRC;
4907                 }
4908                 last TOKEN if $t eq "macdef";
4909                 if ($t eq "machine") {
4910                     push @machines, shift @tokens;
4911                 }
4912             }
4913         }
4914     } else {
4915         $file = $hasdefault = $protected = "";
4916     }
4917
4918     bless {
4919         'mach' => [@machines],
4920         'netrc' => $file,
4921         'hasdefault' => $hasdefault,
4922         'protected' => $protected,
4923     }, $class;
4924 }
4925
4926 # CPAN::FTP::netrc::hasdefault;
4927 sub hasdefault { shift->{'hasdefault'} }
4928 sub netrc      { shift->{'netrc'}      }
4929 sub protected  { shift->{'protected'}  }
4930 sub contains {
4931     my($self,$mach) = @_;
4932     for ( @{$self->{'mach'}} ) {
4933         return 1 if $_ eq $mach;
4934     }
4935     return 0;
4936 }
4937
4938 package CPAN::Complete;
4939 use strict;
4940
4941 sub gnu_cpl {
4942     my($text, $line, $start, $end) = @_;
4943     my(@perlret) = cpl($text, $line, $start);
4944     # find longest common match. Can anybody show me how to peruse
4945     # T::R::Gnu to have this done automatically? Seems expensive.
4946     return () unless @perlret;
4947     my($newtext) = $text;
4948     for (my $i = length($text)+1;;$i++) {
4949         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4950         my $try = substr($perlret[0],0,$i);
4951         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4952         # warn "try[$try]tries[@tries]";
4953         if (@tries == @perlret) {
4954             $newtext = $try;
4955         } else {
4956             last;
4957         }
4958     }
4959     ($newtext,@perlret);
4960 }
4961
4962 #-> sub CPAN::Complete::cpl ;
4963 sub cpl {
4964     my($word,$line,$pos) = @_;
4965     $word ||= "";
4966     $line ||= "";
4967     $pos ||= 0;
4968     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4969     $line =~ s/^\s*//;
4970     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4971         $pos -= length($1);
4972     }
4973     my @return;
4974     if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4975         @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4976     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4977         @return = ();
4978     } elsif ($line =~ /^(a|ls)\s/) {
4979         @return = cplx('CPAN::Author',uc($word));
4980     } elsif ($line =~ /^b\s/) {
4981         CPAN::Shell->local_bundles;
4982         @return = cplx('CPAN::Bundle',$word);
4983     } elsif ($line =~ /^d\s/) {
4984         @return = cplx('CPAN::Distribution',$word);
4985     } elsif ($line =~ m/^(
4986                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4987                          )\s/x ) {
4988         if ($word =~ /^Bundle::/) {
4989             CPAN::Shell->local_bundles;
4990         }
4991         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4992     } elsif ($line =~ /^i\s/) {
4993         @return = cpl_any($word);
4994     } elsif ($line =~ /^reload\s/) {
4995         @return = cpl_reload($word,$line,$pos);
4996     } elsif ($line =~ /^o\s/) {
4997         @return = cpl_option($word,$line,$pos);
4998     } elsif ($line =~ m/^\S+\s/ ) {
4999         # fallback for future commands and what we have forgotten above
5000         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5001     } else {
5002         @return = ();
5003     }
5004     return @return;
5005 }
5006
5007 #-> sub CPAN::Complete::cplx ;
5008 sub cplx {
5009     my($class, $word) = @_;
5010     if (CPAN::_sqlite_running) {
5011         $CPAN::SQLite->search($class, "^\Q$word\E");
5012     }
5013     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5014 }
5015
5016 #-> sub CPAN::Complete::cpl_any ;
5017 sub cpl_any {
5018     my($word) = shift;
5019     return (
5020             cplx('CPAN::Author',$word),
5021             cplx('CPAN::Bundle',$word),
5022             cplx('CPAN::Distribution',$word),
5023             cplx('CPAN::Module',$word),
5024            );
5025 }
5026
5027 #-> sub CPAN::Complete::cpl_reload ;
5028 sub cpl_reload {
5029     my($word,$line,$pos) = @_;
5030     $word ||= "";
5031     my(@words) = split " ", $line;
5032     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5033     my(@ok) = qw(cpan index);
5034     return @ok if @words == 1;
5035     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5036 }
5037
5038 #-> sub CPAN::Complete::cpl_option ;
5039 sub cpl_option {
5040     my($word,$line,$pos) = @_;
5041     $word ||= "";
5042     my(@words) = split " ", $line;
5043     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5044     my(@ok) = qw(conf debug);
5045     return @ok if @words == 1;
5046     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5047     if (0) {
5048     } elsif ($words[1] eq 'index') {
5049         return ();
5050     } elsif ($words[1] eq 'conf') {
5051         return CPAN::HandleConfig::cpl(@_);
5052     } elsif ($words[1] eq 'debug') {
5053         return sort grep /^\Q$word\E/i,
5054             sort keys %CPAN::DEBUG, 'all';
5055     }
5056 }
5057
5058 package CPAN::Index;
5059 use strict;
5060
5061 #-> sub CPAN::Index::force_reload ;
5062 sub force_reload {
5063     my($class) = @_;
5064     $CPAN::Index::LAST_TIME = 0;
5065     $class->reload(1);
5066 }
5067
5068 #-> sub CPAN::Index::reload ;
5069 sub reload {
5070     my($self,$force) = @_;
5071     my $time = time;
5072
5073     # XXX check if a newer one is available. (We currently read it
5074     # from time to time)
5075     for ($CPAN::Config->{index_expire}) {
5076         $_ = 0.001 unless $_ && $_ > 0.001;
5077     }
5078     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
5079         # debug here when CPAN doesn't seem to read the Metadata
5080         require Carp;
5081         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
5082     }
5083     unless ($CPAN::META->{PROTOCOL}) {
5084         $self->read_metadata_cache;
5085         $CPAN::META->{PROTOCOL} ||= "1.0";
5086     }
5087     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
5088         # warn "Setting last_time to 0";
5089         $LAST_TIME = 0; # No warning necessary
5090     }
5091     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
5092         and ! $force) {
5093         # called too often
5094         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
5095     } elsif (0) {
5096         # IFF we are developing, it helps to wipe out the memory
5097         # between reloads, otherwise it is not what a user expects.
5098         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
5099         $CPAN::META = CPAN->new;
5100     } else {
5101         my($debug,$t2);
5102         local $LAST_TIME = $time;
5103         local $CPAN::META->{PROTOCOL} = PROTOCOL;
5104
5105         my $needshort = $^O eq "dos";
5106
5107         $self->rd_authindex($self
5108                           ->reload_x(
5109                                      "authors/01mailrc.txt.gz",
5110                                      $needshort ?
5111                                      File::Spec->catfile('authors', '01mailrc.gz') :
5112                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
5113                                      $force));
5114         $t2 = time;
5115         $debug = "timing reading 01[".($t2 - $time)."]";
5116         $time = $t2;
5117         return if $CPAN::Signal; # this is sometimes lengthy
5118         $self->rd_modpacks($self
5119                          ->reload_x(
5120                                     "modules/02packages.details.txt.gz",
5121                                     $needshort ?
5122                                     File::Spec->catfile('modules', '02packag.gz') :
5123                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
5124                                     $force));
5125         $t2 = time;
5126         $debug .= "02[".($t2 - $time)."]";
5127         $time = $t2;
5128         return if $CPAN::Signal; # this is sometimes lengthy
5129         $self->rd_modlist($self
5130                         ->reload_x(
5131                                    "modules/03modlist.data.gz",
5132                                    $needshort ?
5133                                    File::Spec->catfile('modules', '03mlist.gz') :
5134                                    File::Spec->catfile('modules', '03modlist.data.gz'),
5135                                    $force));
5136         $self->write_metadata_cache;
5137         $t2 = time;
5138         $debug .= "03[".($t2 - $time)."]";
5139         $time = $t2;
5140         CPAN->debug($debug) if $CPAN::DEBUG;
5141     }
5142     if ($CPAN::Config->{build_dir_reuse}) {
5143         $self->reanimate_build_dir;
5144     }
5145     if (CPAN::_sqlite_running) {
5146         $CPAN::SQLite->reload(time => $time, force => $force)
5147             if not $LAST_TIME;
5148     }
5149     $LAST_TIME = $time;
5150     $CPAN::META->{PROTOCOL} = PROTOCOL;
5151 }
5152
5153 #-> sub CPAN::Index::reanimate_build_dir ;
5154 sub reanimate_build_dir {
5155     my($self) = @_;
5156     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
5157         return;
5158     }
5159     return if $HAVE_REANIMATED++;
5160     my $d = $CPAN::Config->{build_dir};
5161     my $dh = DirHandle->new;
5162     opendir $dh, $d or return; # does not exist
5163     my $dirent;
5164     my $i = 0;
5165     my $painted = 0;
5166     my $restored = 0;
5167     my @candidates = map { $_->[0] }
5168         sort { $b->[1] <=> $a->[1] }
5169             map { [ $_, -M File::Spec->catfile($d,$_) ] }
5170                 grep {/\.yml$/} readdir $dh;
5171     unless (@candidates) {
5172         $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
5173         return;
5174     }
5175     $CPAN::Frontend->myprint
5176         (sprintf("Going to read %d yaml file%s from %s/\n",
5177                  scalar @candidates,
5178                  @candidates==1 ? "" : "s",
5179                  $CPAN::Config->{build_dir}
5180                 ));
5181     my $start = CPAN::FTP::_mytime;
5182   DISTRO: for $i (0..$#candidates) {
5183         my $dirent = $candidates[$i];
5184         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
5185         if ($@) {
5186             warn "Error while parsing file '$dirent'; error: '$@'";
5187             next DISTRO;
5188         }
5189         my $c = $y->[0];
5190         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
5191             my $key = $c->{distribution}{ID};
5192             for my $k (keys %{$c->{distribution}}) {
5193                 if ($c->{distribution}{$k}
5194                     && ref $c->{distribution}{$k}
5195                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
5196                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
5197                 }
5198             }
5199
5200             #we tried to restore only if element already
5201             #exists; but then we do not work with metadata
5202             #turned off.
5203             my $do
5204                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
5205                     = $c->{distribution};
5206             for my $skipper (qw(
5207                                 badtestcnt
5208                                 configure_requires_later
5209                                 configure_requires_later_for
5210                                 force_update
5211                                 later
5212                                 later_for
5213                                 notest
5214                                 should_report
5215                                 sponsored_mods
5216                                 prefs
5217                                 negative_prefs_cache
5218                                )) {
5219                 delete $do->{$skipper};
5220             }
5221             # $DB::single = 1;
5222             if ($do->tested_ok_but_not_installed) {
5223                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
5224             }
5225             $restored++;
5226         }
5227         $i++;
5228         while (($painted/76) < ($i/@candidates)) {
5229             $CPAN::Frontend->myprint(".");
5230             $painted++;
5231         }
5232     }
5233     my $took = CPAN::FTP::_mytime - $start;
5234     $CPAN::Frontend->myprint(sprintf(
5235                                      "DONE\nRestored the state of %s (in %.4f secs)\n",
5236                                      $restored || "none",
5237                                      $took,
5238                                     ));
5239 }
5240
5241
5242 #-> sub CPAN::Index::reload_x ;
5243 sub reload_x {
5244     my($cl,$wanted,$localname,$force) = @_;
5245     $force |= 2; # means we're dealing with an index here
5246     CPAN::HandleConfig->load; # we should guarantee loading wherever
5247                               # we rely on Config XXX
5248     $localname ||= $wanted;
5249     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5250                                          $localname);
5251     if (
5252         -f $abs_wanted &&
5253         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5254         !($force & 1)
5255        ) {
5256         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5257         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5258                    qq{day$s. I\'ll use that.});
5259         return $abs_wanted;
5260     } else {
5261         $force |= 1; # means we're quite serious about it.
5262     }
5263     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5264 }
5265
5266 #-> sub CPAN::Index::rd_authindex ;
5267 sub rd_authindex {
5268     my($cl, $index_target) = @_;
5269     return unless defined $index_target;
5270     return if CPAN::_sqlite_running;
5271     my @lines;
5272     $CPAN::Frontend->myprint("Going to read $index_target\n");
5273     local(*FH);
5274     tie *FH, 'CPAN::Tarzip', $index_target;
5275     local($/) = "\n";
5276     local($_);
5277     push @lines, split /\012/ while <FH>;
5278     my $i = 0;
5279     my $painted = 0;
5280     foreach (@lines) {
5281         my($userid,$fullname,$email) =
5282             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5283         $fullname ||= $email;
5284         if ($userid && $fullname && $email) {
5285             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5286             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5287         } else {
5288             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5289         }
5290         $i++;
5291         while (($painted/76) < ($i/@lines)) {
5292             $CPAN::Frontend->myprint(".");
5293             $painted++;
5294         }
5295         return if $CPAN::Signal;
5296     }
5297     $CPAN::Frontend->myprint("DONE\n");
5298 }
5299
5300 sub userid {
5301   my($self,$dist) = @_;
5302   $dist = $self->{'id'} unless defined $dist;
5303   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5304   $ret;
5305 }
5306
5307 #-> sub CPAN::Index::rd_modpacks ;
5308 sub rd_modpacks {
5309     my($self, $index_target) = @_;
5310     return unless defined $index_target;
5311     return if CPAN::_sqlite_running;
5312     $CPAN::Frontend->myprint("Going to read $index_target\n");
5313     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5314     local $_;
5315     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5316     my $slurp = "";
5317     my $chunk;
5318     while (my $bytes = $fh->READ(\$chunk,8192)) {
5319         $slurp.=$chunk;
5320     }
5321     my @lines = split /\012/, $slurp;
5322     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5323     undef $fh;
5324     # read header
5325     my($line_count,$last_updated);
5326     while (@lines) {
5327         my $shift = shift(@lines);
5328         last if $shift =~ /^\s*$/;
5329         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5330         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5331     }
5332     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5333     if (not defined $line_count) {
5334
5335         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5336 Please check the validity of the index file by comparing it to more
5337 than one CPAN mirror. I'll continue but problems seem likely to
5338 happen.\a
5339 });
5340
5341         $CPAN::Frontend->mysleep(5);
5342     } elsif ($line_count != scalar @lines) {
5343
5344         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5345 contains a Line-Count header of %d but I see %d lines there. Please
5346 check the validity of the index file by comparing it to more than one
5347 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5348 $index_target, $line_count, scalar(@lines));
5349
5350     }
5351     if (not defined $last_updated) {
5352
5353         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5354 Please check the validity of the index file by comparing it to more
5355 than one CPAN mirror. I'll continue but problems seem likely to
5356 happen.\a
5357 });
5358
5359         $CPAN::Frontend->mysleep(5);
5360     } else {
5361
5362         $CPAN::Frontend
5363             ->myprint(sprintf qq{  Database was generated on %s\n},
5364                       $last_updated);
5365         $DATE_OF_02 = $last_updated;
5366
5367         my $age = time;
5368         if ($CPAN::META->has_inst('HTTP::Date')) {
5369             require HTTP::Date;
5370             $age -= HTTP::Date::str2time($last_updated);
5371         } else {
5372             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5373             require Time::Local;
5374             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5375             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5376             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5377         }
5378         $age /= 3600*24;
5379         if ($age > 30) {
5380
5381             $CPAN::Frontend
5382                 ->mywarn(sprintf
5383                          qq{Warning: This index file is %d days old.
5384   Please check the host you chose as your CPAN mirror for staleness.
5385   I'll continue but problems seem likely to happen.\a\n},
5386                          $age);
5387
5388         } elsif ($age < -1) {
5389
5390             $CPAN::Frontend
5391                 ->mywarn(sprintf
5392                          qq{Warning: Your system date is %d days behind this index file!
5393   System time:          %s
5394   Timestamp index file: %s
5395   Please fix your system time, problems with the make command expected.\n},
5396                          -$age,
5397                          scalar gmtime,
5398                          $DATE_OF_02,
5399                         );
5400
5401         }
5402     }
5403
5404
5405     # A necessity since we have metadata_cache: delete what isn't
5406     # there anymore
5407     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5408     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5409     my(%exists);
5410     my $i = 0;
5411     my $painted = 0;
5412     foreach (@lines) {
5413         # before 1.56 we split into 3 and discarded the rest. From
5414         # 1.57 we assign remaining text to $comment thus allowing to
5415         # influence isa_perl
5416         my($mod,$version,$dist,$comment) = split " ", $_, 4;
5417         unless ($mod && defined $version && $dist) {
5418             $CPAN::Frontend->mywarn("Could not split line[$_]\n");
5419             next;
5420         }
5421         my($bundle,$id,$userid);
5422
5423         if ($mod eq 'CPAN' &&
5424             ! (
5425             CPAN::Queue->exists('Bundle::CPAN') ||
5426             CPAN::Queue->exists('CPAN')
5427             )
5428         ) {
5429             local($^W)= 0;
5430             if ($version > $CPAN::VERSION) {
5431                 $CPAN::Frontend->mywarn(qq{
5432   New CPAN.pm version (v$version) available.
5433   [Currently running version is v$CPAN::VERSION]
5434   You might want to try
5435     install CPAN
5436     reload cpan
5437   to both upgrade CPAN.pm and run the new version without leaving
5438   the current session.
5439
5440 }); #});
5441                 $CPAN::Frontend->mysleep(2);
5442                 $CPAN::Frontend->myprint(qq{\n});
5443             }
5444             last if $CPAN::Signal;
5445         } elsif ($mod =~ /^Bundle::(.*)/) {
5446             $bundle = $1;
5447         }
5448
5449         if ($bundle) {
5450             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5451             # Let's make it a module too, because bundles have so much
5452             # in common with modules.
5453
5454             # Changed in 1.57_63: seems like memory bloat now without
5455             # any value, so commented out
5456
5457             # $CPAN::META->instance('CPAN::Module',$mod);
5458
5459         } else {
5460
5461             # instantiate a module object
5462             $id = $CPAN::META->instance('CPAN::Module',$mod);
5463
5464         }
5465
5466         # Although CPAN prohibits same name with different version the
5467         # indexer may have changed the version for the same distro
5468         # since the last time ("Force Reindexing" feature)
5469         if ($id->cpan_file ne $dist
5470             ||
5471             $id->cpan_version ne $version
5472            ) {
5473             $userid = $id->userid || $self->userid($dist);
5474             $id->set(
5475                      'CPAN_USERID' => $userid,
5476                      'CPAN_VERSION' => $version,
5477                      'CPAN_FILE' => $dist,
5478                     );
5479         }
5480
5481         # instantiate a distribution object
5482         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5483         # we do not need CONTAINSMODS unless we do something with
5484         # this dist, so we better produce it on demand.
5485
5486         ## my $obj = $CPAN::META->instance(
5487         ##                                 'CPAN::Distribution' => $dist
5488         ##                                );
5489         ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5490         } else {
5491             $CPAN::META->instance(
5492                                   'CPAN::Distribution' => $dist
5493                                  )->set(
5494                                         'CPAN_USERID' => $userid,
5495                                         'CPAN_COMMENT' => $comment,
5496                                        );
5497         }
5498         if ($secondtime) {
5499             for my $name ($mod,$dist) {
5500                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5501                 $exists{$name} = undef;
5502             }
5503         }
5504         $i++;
5505         while (($painted/76) < ($i/@lines)) {
5506             $CPAN::Frontend->myprint(".");
5507             $painted++;
5508         }
5509         return if $CPAN::Signal;
5510     }
5511     $CPAN::Frontend->myprint("DONE\n");
5512     if ($secondtime) {
5513         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5514             for my $o ($CPAN::META->all_objects($class)) {
5515                 next if exists $exists{$o->{ID}};
5516                 $CPAN::META->delete($class,$o->{ID});
5517                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5518                 #     if $CPAN::DEBUG;
5519             }
5520         }
5521     }
5522 }
5523
5524 #-> sub CPAN::Index::rd_modlist ;
5525 sub rd_modlist {
5526     my($cl,$index_target) = @_;
5527     return unless defined $index_target;
5528     return if CPAN::_sqlite_running;
5529     $CPAN::Frontend->myprint("Going to read $index_target\n");
5530     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5531     local $_;
5532     my $slurp = "";
5533     my $chunk;
5534     while (my $bytes = $fh->READ(\$chunk,8192)) {
5535         $slurp.=$chunk;
5536     }
5537     my @eval2 = split /\012/, $slurp;
5538
5539     while (@eval2) {
5540         my $shift = shift(@eval2);
5541         if ($shift =~ /^Date:\s+(.*)/) {
5542             if ($DATE_OF_03 eq $1) {
5543                 $CPAN::Frontend->myprint("Unchanged.\n");
5544                 return;
5545             }
5546             ($DATE_OF_03) = $1;
5547         }
5548         last if $shift =~ /^\s*$/;
5549     }
5550     push @eval2, q{CPAN::Modulelist->data;};
5551     local($^W) = 0;
5552     my($compmt) = Safe->new("CPAN::Safe1");
5553     my($eval2) = join("\n", @eval2);
5554     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5555     my $ret = $compmt->reval($eval2);
5556     Carp::confess($@) if $@;
5557     return if $CPAN::Signal;
5558     my $i = 0;
5559     my $until = keys(%$ret);
5560     my $painted = 0;
5561     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5562     for (keys %$ret) {
5563         my $obj = $CPAN::META->instance("CPAN::Module",$_);
5564         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5565         $obj->set(%{$ret->{$_}});
5566         $i++;
5567         while (($painted/76) < ($i/$until)) {
5568             $CPAN::Frontend->myprint(".");
5569             $painted++;
5570         }
5571         return if $CPAN::Signal;
5572     }
5573     $CPAN::Frontend->myprint("DONE\n");
5574 }
5575
5576 #-> sub CPAN::Index::write_metadata_cache ;
5577 sub write_metadata_cache {
5578     my($self) = @_;
5579     return unless $CPAN::Config->{'cache_metadata'};
5580     return if CPAN::_sqlite_running;
5581     return unless $CPAN::META->has_usable("Storable");
5582     my $cache;
5583     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5584                       CPAN::Distribution)) {
5585         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5586     }
5587     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5588     $cache->{last_time} = $LAST_TIME;
5589     $cache->{DATE_OF_02} = $DATE_OF_02;
5590     $cache->{PROTOCOL} = PROTOCOL;
5591     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5592     eval { Storable::nstore($cache, $metadata_file) };
5593     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5594 }
5595
5596 #-> sub CPAN::Index::read_metadata_cache ;
5597 sub read_metadata_cache {
5598     my($self) = @_;
5599     return unless $CPAN::Config->{'cache_metadata'};
5600     return if CPAN::_sqlite_running;
5601     return unless $CPAN::META->has_usable("Storable");
5602     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5603     return unless -r $metadata_file and -f $metadata_file;
5604     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5605     my $cache;
5606     eval { $cache = Storable::retrieve($metadata_file) };
5607     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5608     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5609         $LAST_TIME = 0;
5610         return;
5611     }
5612     if (exists $cache->{PROTOCOL}) {
5613         if (PROTOCOL > $cache->{PROTOCOL}) {
5614             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5615                                             "with protocol v%s, requiring v%s\n",
5616                                             $cache->{PROTOCOL},
5617                                             PROTOCOL)
5618                                    );
5619             return;
5620         }
5621     } else {
5622         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5623                                 "with protocol v1.0\n");
5624         return;
5625     }
5626     my $clcnt = 0;
5627     my $idcnt = 0;
5628     while(my($class,$v) = each %$cache) {
5629         next unless $class =~ /^CPAN::/;
5630         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5631         while (my($id,$ro) = each %$v) {
5632             $CPAN::META->{readwrite}{$class}{$id} ||=
5633                 $class->new(ID=>$id, RO=>$ro);
5634             $idcnt++;
5635         }
5636         $clcnt++;
5637     }
5638     unless ($clcnt) { # sanity check
5639         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5640         return;
5641     }
5642     if ($idcnt < 1000) {
5643         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5644                                  "in $metadata_file\n");
5645         return;
5646     }
5647     $CPAN::META->{PROTOCOL} ||=
5648         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5649                             # does initialize to some protocol
5650     $LAST_TIME = $cache->{last_time};
5651     $DATE_OF_02 = $cache->{DATE_OF_02};
5652     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5653         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5654     return;
5655 }
5656
5657 package CPAN::InfoObj;
5658 use strict;
5659 use Cwd qw(chdir);
5660
5661 sub ro {
5662     my $self = shift;
5663     exists $self->{RO} and return $self->{RO};
5664 }
5665
5666 #-> sub CPAN::InfoObj::cpan_userid
5667 sub cpan_userid {
5668     my $self = shift;
5669     my $ro = $self->ro;
5670     if ($ro) {
5671         return $ro->{CPAN_USERID} || "N/A";
5672     } else {
5673         $self->debug("ID[$self->{ID}]");
5674         # N/A for bundles found locally
5675         return "N/A";
5676     }
5677 }
5678
5679 sub id { shift->{ID}; }
5680
5681 #-> sub CPAN::InfoObj::new ;
5682 sub new {
5683     my $this = bless {}, shift;
5684     %$this = @_;
5685     $this
5686 }
5687
5688 # The set method may only be used by code that reads index data or
5689 # otherwise "objective" data from the outside world. All session
5690 # related material may do anything else with instance variables but
5691 # must not touch the hash under the RO attribute. The reason is that
5692 # the RO hash gets written to Metadata file and is thus persistent.
5693
5694 #-> sub CPAN::InfoObj::safe_chdir ;
5695 sub safe_chdir {
5696   my($self,$todir) = @_;
5697   # we die if we cannot chdir and we are debuggable
5698   Carp::confess("safe_chdir called without todir argument")
5699         unless defined $todir and length $todir;
5700   if (chdir $todir) {
5701     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5702         if $CPAN::DEBUG;
5703   } else {
5704     if (-e $todir) {
5705         unless (-x $todir) {
5706             unless (chmod 0755, $todir) {
5707                 my $cwd = CPAN::anycwd();
5708                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5709                                         "permission to change the permission; cannot ".
5710                                         "chdir to '$todir'\n");
5711                 $CPAN::Frontend->mysleep(5);
5712                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5713                                        qq{to todir[$todir]: $!});
5714             }
5715         }
5716     } else {
5717         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5718     }
5719     if (chdir $todir) {
5720       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5721           if $CPAN::DEBUG;
5722     } else {
5723       my $cwd = CPAN::anycwd();
5724       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5725                              qq{to todir[$todir] (a chmod has been issued): $!});
5726     }
5727   }
5728 }
5729
5730 #-> sub CPAN::InfoObj::set ;
5731 sub set {
5732     my($self,%att) = @_;
5733     my $class = ref $self;
5734
5735     # This must be ||=, not ||, because only if we write an empty
5736     # reference, only then the set method will write into the readonly
5737     # area. But for Distributions that spring into existence, maybe
5738     # because of a typo, we do not like it that they are written into
5739     # the readonly area and made permanent (at least for a while) and
5740     # that is why we do not "allow" other places to call ->set.
5741     unless ($self->id) {
5742         CPAN->debug("Bug? Empty ID, rejecting");
5743         return;
5744     }
5745     my $ro = $self->{RO} =
5746         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5747
5748     while (my($k,$v) = each %att) {
5749         $ro->{$k} = $v;
5750     }
5751 }
5752
5753 #-> sub CPAN::InfoObj::as_glimpse ;
5754 sub as_glimpse {
5755     my($self) = @_;
5756     my(@m);
5757     my $class = ref($self);
5758     $class =~ s/^CPAN:://;
5759     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5760     push @m, sprintf "%-15s %s\n", $class, $id;
5761     join "", @m;
5762 }
5763
5764 #-> sub CPAN::InfoObj::as_string ;
5765 sub as_string {
5766     my($self) = @_;
5767     my(@m);
5768     my $class = ref($self);
5769     $class =~ s/^CPAN:://;
5770     push @m, $class, " id = $self->{ID}\n";
5771     my $ro;
5772     unless ($ro = $self->ro) {
5773         if (substr($self->{ID},-1,1) eq ".") { # directory
5774             $ro = +{};
5775         } else {
5776             $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5777             $CPAN::Frontend->mysleep(5);
5778             return;
5779         }
5780     }
5781     for (sort keys %$ro) {
5782         # next if m/^(ID|RO)$/;
5783         my $extra = "";
5784         if ($_ eq "CPAN_USERID") {
5785             $extra .= " (";
5786             $extra .= $self->fullname;
5787             my $email; # old perls!
5788             if ($email = $CPAN::META->instance("CPAN::Author",
5789                                                $self->cpan_userid
5790                                               )->email) {
5791                 $extra .= " <$email>";
5792             } else {
5793                 $extra .= " <no email>";
5794             }
5795             $extra .= ")";
5796         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5797             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5798             next;
5799         }
5800         next unless defined $ro->{$_};
5801         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5802     }
5803   KEY: for (sort keys %$self) {
5804         next if m/^(ID|RO)$/;
5805         unless (defined $self->{$_}) {
5806             delete $self->{$_};
5807             next KEY;
5808         }
5809         if (ref($self->{$_}) eq "ARRAY") {
5810             push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5811         } elsif (ref($self->{$_}) eq "HASH") {
5812             my $value;
5813             if (/^CONTAINSMODS$/) {
5814                 $value = join(" ",sort keys %{$self->{$_}});
5815             } elsif (/^prereq_pm$/) {
5816                 my @value;
5817                 my $v = $self->{$_};
5818                 for my $x (sort keys %$v) {
5819                     my @svalue;
5820                     for my $y (sort keys %{$v->{$x}}) {
5821                         push @svalue, "$y=>$v->{$x}{$y}";
5822                     }
5823                     push @value, "$x\:" . join ",", @svalue if @svalue;
5824                 }
5825                 $value = join ";", @value;
5826             } else {
5827                 $value = $self->{$_};
5828             }
5829             push @m, sprintf(
5830                              "    %-12s %s\n",
5831                              $_,
5832                              $value,
5833                             );
5834         } else {
5835             push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5836         }
5837     }
5838     join "", @m, "\n";
5839 }
5840
5841 #-> sub CPAN::InfoObj::fullname ;
5842 sub fullname {
5843     my($self) = @_;
5844     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5845 }
5846
5847 #-> sub CPAN::InfoObj::dump ;
5848 sub dump {
5849     my($self, $what) = @_;
5850     unless ($CPAN::META->has_inst("Data::Dumper")) {
5851         $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5852     }
5853     local $Data::Dumper::Sortkeys;
5854     $Data::Dumper::Sortkeys = 1;
5855     my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5856     if (length $out > 100000) {
5857         my $fh_pager = FileHandle->new;
5858         local($SIG{PIPE}) = "IGNORE";
5859         my $pager = $CPAN::Config->{'pager'} || "cat";
5860         $fh_pager->open("|$pager")
5861             or die "Could not open pager $pager\: $!";
5862         $fh_pager->print($out);
5863         close $fh_pager;
5864     } else {
5865         $CPAN::Frontend->myprint($out);
5866     }
5867 }
5868
5869 package CPAN::Author;
5870 use strict;
5871
5872 #-> sub CPAN::Author::force
5873 sub force {
5874     my $self = shift;
5875     $self->{force}++;
5876 }
5877
5878 #-> sub CPAN::Author::force
5879 sub unforce {
5880     my $self = shift;
5881     delete $self->{force};
5882 }
5883
5884 #-> sub CPAN::Author::id
5885 sub id {
5886     my $self = shift;
5887     my $id = $self->{ID};
5888     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5889     $id;
5890 }
5891
5892 #-> sub CPAN::Author::as_glimpse ;
5893 sub as_glimpse {
5894     my($self) = @_;
5895     my(@m);
5896     my $class = ref($self);
5897     $class =~ s/^CPAN:://;
5898     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5899                      $class,
5900                      $self->{ID},
5901                      $self->fullname,
5902                      $self->email);
5903     join "", @m;
5904 }
5905
5906 #-> sub CPAN::Author::fullname ;
5907 sub fullname {
5908     shift->ro->{FULLNAME};
5909 }
5910 *name = \&fullname;
5911
5912 #-> sub CPAN::Author::email ;
5913 sub email    { shift->ro->{EMAIL}; }
5914
5915 #-> sub CPAN::Author::ls ;
5916 sub ls {
5917     my $self = shift;
5918     my $glob = shift || "";
5919     my $silent = shift || 0;
5920     my $id = $self->id;
5921
5922     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5923     my(@csf); # chksumfile
5924     @csf = $self->id =~ /(.)(.)(.*)/;
5925     $csf[1] = join "", @csf[0,1];
5926     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5927     my(@dl);
5928     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5929     unless (grep {$_->[2] eq $csf[1]} @dl) {
5930         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5931         return;
5932     }
5933     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5934     unless (grep {$_->[2] eq $csf[2]} @dl) {
5935         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5936         return;
5937     }
5938     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5939     if ($glob) {
5940         if ($CPAN::META->has_inst("Text::Glob")) {
5941             my $rglob = Text::Glob::glob_to_regex($glob);
5942             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5943         } else {
5944             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5945         }
5946     }
5947     unless ($silent >= 2) {
5948         $CPAN::Frontend->myprint(join "", map {
5949             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5950         } sort { $a->[2] cmp $b->[2] } @dl);
5951     }
5952     @dl;
5953 }
5954
5955 # returns an array of arrays, the latter contain (size,mtime,filename)
5956 #-> sub CPAN::Author::dir_listing ;
5957 sub dir_listing {
5958     my $self = shift;
5959     my $chksumfile = shift;
5960     my $recursive = shift;
5961     my $may_ftp = shift;
5962
5963     my $lc_want =
5964         File::Spec->catfile($CPAN::Config->{keep_source_where},
5965                             "authors", "id", @$chksumfile);
5966
5967     my $fh;
5968
5969     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5970     # hazard.  (Without GPG installed they are not that much better,
5971     # though.)
5972     $fh = FileHandle->new;
5973     if (open($fh, $lc_want)) {
5974         my $line = <$fh>; close $fh;
5975         unlink($lc_want) unless $line =~ /PGP/;
5976     }
5977
5978     local($") = "/";
5979     # connect "force" argument with "index_expire".
5980     my $force = $self->{force};
5981     if (my @stat = stat $lc_want) {
5982         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5983     }
5984     my $lc_file;
5985     if ($may_ftp) {
5986         $lc_file = CPAN::FTP->localize(
5987                                        "authors/id/@$chksumfile",
5988                                        $lc_want,
5989                                        $force,
5990                                       );
5991         unless ($lc_file) {
5992             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5993             $chksumfile->[-1] .= ".gz";
5994             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5995                                            "$lc_want.gz",1);
5996             if ($lc_file) {
5997                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5998                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5999             } else {
6000                 return;
6001             }
6002         }
6003     } else {
6004         $lc_file = $lc_want;
6005         # we *could* second-guess and if the user has a file: URL,
6006         # then we could look there. But on the other hand, if they do
6007         # have a file: URL, wy did they choose to set
6008         # $CPAN::Config->{show_upload_date} to false?
6009     }
6010
6011     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
6012     $fh = FileHandle->new;
6013     my($cksum);
6014     if (open $fh, $lc_file) {
6015         local($/);
6016         my $eval = <$fh>;
6017         $eval =~ s/\015?\012/\n/g;
6018         close $fh;
6019         my($compmt) = Safe->new();
6020         $cksum = $compmt->reval($eval);
6021         if ($@) {
6022             rename $lc_file, "$lc_file.bad";
6023             Carp::confess($@) if $@;
6024         }
6025     } elsif ($may_ftp) {
6026         Carp::carp "Could not open '$lc_file' for reading.";
6027     } else {
6028         # Maybe should warn: "You may want to set show_upload_date to a true value"
6029         return;
6030     }
6031     my(@result,$f);
6032     for $f (sort keys %$cksum) {
6033         if (exists $cksum->{$f}{isdir}) {
6034             if ($recursive) {
6035                 my(@dir) = @$chksumfile;
6036                 pop @dir;
6037                 push @dir, $f, "CHECKSUMS";
6038                 push @result, map {
6039                     [$_->[0], $_->[1], "$f/$_->[2]"]
6040                 } $self->dir_listing(\@dir,1,$may_ftp);
6041             } else {
6042                 push @result, [ 0, "-", $f ];
6043             }
6044         } else {
6045             push @result, [
6046                            ($cksum->{$f}{"size"}||0),
6047                            $cksum->{$f}{"mtime"}||"---",
6048                            $f
6049                           ];
6050         }
6051     }
6052     @result;
6053 }
6054
6055 #-> sub CPAN::Author::reports
6056 sub reports {
6057     $CPAN::Frontend->mywarn("reports on authors not implemented.
6058 Please file a bugreport if you need this.\n");
6059 }
6060
6061 package CPAN::Distribution;
6062 use strict;
6063 use Cwd qw(chdir);
6064 use CPAN::Distroprefs;
6065
6066 # Accessors
6067 sub cpan_comment {
6068     my $self = shift;
6069     my $ro = $self->ro or return;
6070     $ro->{CPAN_COMMENT}
6071 }
6072
6073 #-> CPAN::Distribution::undelay
6074 sub undelay {
6075     my $self = shift;
6076     for my $delayer (
6077                      "configure_requires_later",
6078                      "configure_requires_later_for",
6079                      "later",
6080                      "later_for",
6081                     ) {
6082         delete $self->{$delayer};
6083     }
6084 }
6085
6086 #-> CPAN::Distribution::is_dot_dist
6087 sub is_dot_dist {
6088     my($self) = @_;
6089     return substr($self->id,-1,1) eq ".";
6090 }
6091
6092 # add the A/AN/ stuff
6093 #-> CPAN::Distribution::normalize
6094 sub normalize {
6095     my($self,$s) = @_;
6096     $s = $self->id unless defined $s;
6097     if (substr($s,-1,1) eq ".") {
6098         # using a global because we are sometimes called as static method
6099         if (!$CPAN::META->{LOCK}
6100             && !$CPAN::Have_warned->{"$s is unlocked"}++
6101            ) {
6102             $CPAN::Frontend->mywarn("You are visiting the local directory
6103   '$s'
6104   without lock, take care that concurrent processes do not do likewise.\n");
6105             $CPAN::Frontend->mysleep(1);
6106         }
6107         if ($s eq ".") {
6108             $s = "$CPAN::iCwd/.";
6109         } elsif (File::Spec->file_name_is_absolute($s)) {
6110         } elsif (File::Spec->can("rel2abs")) {
6111             $s = File::Spec->rel2abs($s);
6112         } else {
6113             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
6114         }
6115         CPAN->debug("s[$s]") if $CPAN::DEBUG;
6116         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
6117             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
6118                 $_->{build_dir} = $s;
6119                 $_->{archived} = "local_directory";
6120                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
6121             }
6122         }
6123     } elsif (
6124         $s =~ tr|/|| == 1
6125         or
6126         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
6127        ) {
6128         return $s if $s =~ m:^N/A|^Contact Author: ;
6129         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
6130         CPAN->debug("s[$s]") if $CPAN::DEBUG;
6131     }
6132     $s;
6133 }
6134
6135 #-> sub CPAN::Distribution::author ;
6136 sub author {
6137     my($self) = @_;
6138     my($authorid);
6139     if (substr($self->id,-1,1) eq ".") {
6140         $authorid = "LOCAL";
6141     } else {
6142         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
6143     }
6144     CPAN::Shell->expand("Author",$authorid);
6145 }
6146
6147 # tries to get the yaml from CPAN instead of the distro itself:
6148 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
6149 sub fast_yaml {
6150     my($self) = @_;
6151     my $meta = $self->pretty_id;
6152     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
6153     my(@ls) = CPAN::Shell->globls($meta);
6154     my $norm = $self->normalize($meta);
6155
6156     my($local_file);
6157     my($local_wanted) =
6158         File::Spec->catfile(
6159                             $CPAN::Config->{keep_source_where},
6160                             "authors",
6161                             "id",
6162                             split(/\//,$norm)
6163                            );
6164     $self->debug("Doing localize") if $CPAN::DEBUG;
6165     unless ($local_file =
6166             CPAN::FTP->localize("authors/id/$norm",
6167                                 $local_wanted)) {
6168         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
6169     }
6170     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
6171 }
6172
6173 #-> sub CPAN::Distribution::cpan_userid
6174 sub cpan_userid {
6175     my $self = shift;
6176     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
6177         return $1;
6178     }
6179     return $self->SUPER::cpan_userid;
6180 }
6181
6182 #-> sub CPAN::Distribution::pretty_id
6183 sub pretty_id {
6184     my $self = shift;
6185     my $id = $self->id;
6186     return $id unless $id =~ m|^./../|;
6187     substr($id,5);
6188 }
6189
6190 #-> sub CPAN::Distribution::base_id
6191 sub base_id {
6192     my $self = shift;
6193     my $id = $self->pretty_id();
6194     my $base_id = File::Basename::basename($id);
6195     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
6196     return $base_id;
6197 }
6198
6199 #-> sub CPAN::Distribution::tested_ok_but_not_installed
6200 sub tested_ok_but_not_installed {
6201     my $self = shift;
6202     return (
6203            $self->{make_test}
6204         && $self->{build_dir}
6205         && (UNIVERSAL::can($self->{make_test},"failed") ?
6206              ! $self->{make_test}->failed :
6207              $self->{make_test} =~ /^YES/
6208             )
6209         && (
6210             !$self->{install}
6211             ||
6212             $self->{install}->failed
6213            )
6214     );
6215 }
6216
6217
6218 # mark as dirty/clean for the sake of recursion detection. $color=1
6219 # means "in use", $color=0 means "not in use anymore". $color=2 means
6220 # we have determined prereqs now and thus insist on passing this
6221 # through (at least) once again.
6222
6223 #-> sub CPAN::Distribution::color_cmd_tmps ;
6224 sub color_cmd_tmps {
6225     my($self) = shift;
6226     my($depth) = shift || 0;
6227     my($color) = shift || 0;
6228     my($ancestors) = shift || [];
6229     # a distribution needs to recurse into its prereq_pms
6230
6231     return if exists $self->{incommandcolor}
6232         && $color==1
6233         && $self->{incommandcolor}==$color;
6234     if ($depth>=$CPAN::MAX_RECURSION) {
6235         die(CPAN::Exception::RecursiveDependency->new($ancestors));
6236     }
6237     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6238     my $prereq_pm = $self->prereq_pm;
6239     if (defined $prereq_pm) {
6240       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
6241                            keys %{$prereq_pm->{build_requires}||{}}) {
6242             next PREREQ if $pre eq "perl";
6243             my $premo;
6244             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
6245                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
6246                 $CPAN::Frontend->mysleep(2);
6247                 next PREREQ;
6248             }
6249             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6250         }
6251     }
6252     if ($color==0) {
6253         delete $self->{sponsored_mods};
6254
6255         # as we are at the end of a command, we'll give up this
6256         # reminder of a broken test. Other commands may test this guy
6257         # again. Maybe 'badtestcnt' should be renamed to
6258         # 'make_test_failed_within_command'?
6259         delete $self->{badtestcnt};
6260     }
6261     $self->{incommandcolor} = $color;
6262 }
6263
6264 #-> sub CPAN::Distribution::as_string ;
6265 sub as_string {
6266     my $self = shift;
6267     $self->containsmods;
6268     $self->upload_date;
6269     $self->SUPER::as_string(@_);
6270 }
6271
6272 #-> sub CPAN::Distribution::containsmods ;
6273 sub containsmods {
6274     my $self = shift;
6275     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6276     my $dist_id = $self->{ID};
6277     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6278         my $mod_file = $mod->cpan_file or next;
6279         my $mod_id = $mod->{ID} or next;
6280         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6281         # sleep 1;
6282         if ($CPAN::Signal) {
6283             delete $self->{CONTAINSMODS};
6284             return;
6285         }
6286         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6287     }
6288     keys %{$self->{CONTAINSMODS}||={}};
6289 }
6290
6291 #-> sub CPAN::Distribution::upload_date ;
6292 sub upload_date {
6293     my $self = shift;
6294     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6295     my(@local_wanted) = split(/\//,$self->id);
6296     my $filename = pop @local_wanted;
6297     push @local_wanted, "CHECKSUMS";
6298     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6299     return unless $author;
6300     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6301     return unless @dl;
6302     my($dirent) = grep { $_->[2] eq $filename } @dl;
6303     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6304     return unless $dirent->[1];
6305     return $self->{UPLOAD_DATE} = $dirent->[1];
6306 }
6307
6308 #-> sub CPAN::Distribution::uptodate ;
6309 sub uptodate {
6310     my($self) = @_;
6311     my $c;
6312     foreach $c ($self->containsmods) {
6313         my $obj = CPAN::Shell->expandany($c);
6314         unless ($obj->uptodate) {
6315             my $id = $self->pretty_id;
6316             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6317             return 0;
6318         }
6319     }
6320     return 1;
6321 }
6322
6323 #-> sub CPAN::Distribution::called_for ;
6324 sub called_for {
6325     my($self,$id) = @_;
6326     $self->{CALLED_FOR} = $id if defined $id;
6327     return $self->{CALLED_FOR};
6328 }
6329
6330 #-> sub CPAN::Distribution::get ;
6331 sub get {
6332     my($self) = @_;
6333     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6334     if (my $goto = $self->prefs->{goto}) {
6335         $CPAN::Frontend->mywarn
6336             (sprintf(
6337                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6338                      $goto,
6339                      $self->{prefs_file},
6340                      $self->{prefs_file_doc},
6341                     ));
6342         return $self->goto($goto);
6343     }
6344     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6345                            ? $ENV{PERL5LIB}
6346                            : ($ENV{PERLLIB} || "");
6347     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
6348     $CPAN::META->set_perl5lib;
6349     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6350
6351   EXCUSE: {
6352         my @e;
6353         my $goodbye_message;
6354         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6355         if ($self->prefs->{disabled} && ! $self->{force_update}) {
6356             my $why = sprintf(
6357                               "Disabled via prefs file '%s' doc %d",
6358                               $self->{prefs_file},
6359                               $self->{prefs_file_doc},
6360                              );
6361             push @e, $why;
6362             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6363             $goodbye_message = "[disabled] -- NA $why";
6364             # note: not intended to be persistent but at least visible
6365             # during this session
6366         } else {
6367             if (exists $self->{build_dir} && -d $self->{build_dir}
6368                 && ($self->{modulebuild}||$self->{writemakefile})
6369                ) {
6370                 # this deserves print, not warn:
6371                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6372                                          "$self->{build_dir}\n"
6373                                         );
6374                 return 1;
6375             }
6376
6377             # although we talk about 'force' we shall not test on
6378             # force directly. New model of force tries to refrain from
6379             # direct checking of force.
6380             exists $self->{unwrapped} and (
6381                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
6382                                            $self->{unwrapped}->failed :
6383                                            $self->{unwrapped} =~ /^NO/
6384                                           )
6385                 and push @e, "Unwrapping had some problem, won't try again without force";
6386         }
6387         if (@e) {
6388             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6389             if ($goodbye_message) {
6390                  $self->goodbye($goodbye_message);
6391             }
6392             return;
6393         }
6394     }
6395     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6396
6397     my($local_file);
6398     unless ($self->{build_dir} && -d $self->{build_dir}) {
6399         $self->get_file_onto_local_disk;
6400         return if $CPAN::Signal;
6401         $self->check_integrity;
6402         return if $CPAN::Signal;
6403         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6404         if (exists $self->{writemakefile} && ref $self->{writemakefile}
6405            && $self->{writemakefile}->can("failed") &&
6406            $self->{writemakefile}->failed) {
6407             return;
6408         }
6409         $packagedir ||= $self->{build_dir};
6410         $self->{build_dir} = $packagedir;
6411     }
6412
6413     if ($CPAN::Signal) {
6414         $self->safe_chdir($sub_wd);
6415         return;
6416     }
6417     return $self->choose_MM_or_MB($local_file);
6418 }
6419
6420 #-> CPAN::Distribution::get_file_onto_local_disk
6421 sub get_file_onto_local_disk {
6422     my($self) = @_;
6423
6424     return if $self->is_dot_dist;
6425     my($local_file);
6426     my($local_wanted) =
6427         File::Spec->catfile(
6428                             $CPAN::Config->{keep_source_where},
6429                             "authors",
6430                             "id",
6431                             split(/\//,$self->id)
6432                            );
6433
6434     $self->debug("Doing localize") if $CPAN::DEBUG;
6435     unless ($local_file =
6436             CPAN::FTP->localize("authors/id/$self->{ID}",
6437                                 $local_wanted)) {
6438         my $note = "";
6439         if ($CPAN::Index::DATE_OF_02) {
6440             $note = "Note: Current database in memory was generated ".
6441                 "on $CPAN::Index::DATE_OF_02\n";
6442         }
6443         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6444     }
6445
6446     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6447     $self->{localfile} = $local_file;
6448 }
6449
6450
6451 #-> CPAN::Distribution::check_integrity
6452 sub check_integrity {
6453     my($self) = @_;
6454
6455     return if $self->is_dot_dist;
6456     if ($CPAN::META->has_inst("Digest::SHA")) {
6457         $self->debug("Digest::SHA is installed, verifying");
6458         $self->verifyCHECKSUM;
6459     } else {
6460         $self->debug("Digest::SHA is NOT installed");
6461     }
6462 }
6463
6464 #-> CPAN::Distribution::run_preps_on_packagedir
6465 sub run_preps_on_packagedir {
6466     my($self) = @_;
6467     return if $self->is_dot_dist;
6468
6469     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6470     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6471     $self->safe_chdir($builddir);
6472     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6473     File::Path::rmtree("tmp-$$");
6474     unless (mkdir "tmp-$$", 0755) {
6475         $CPAN::Frontend->unrecoverable_error(<<EOF);
6476 Couldn't mkdir '$builddir/tmp-$$': $!
6477
6478 Cannot continue: Please find the reason why I cannot make the
6479 directory
6480 $builddir/tmp-$$
6481 and fix the problem, then retry.
6482
6483 EOF
6484     }
6485     if ($CPAN::Signal) {
6486         return;
6487     }
6488     $self->safe_chdir("tmp-$$");
6489
6490     #
6491     # Unpack the goods
6492     #
6493     my $local_file = $self->{localfile};
6494     my $ct = eval{CPAN::Tarzip->new($local_file)};
6495     unless ($ct) {
6496         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6497         delete $self->{build_dir};
6498         return;
6499     }
6500     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6501         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6502         $self->untar_me($ct);
6503     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6504         $self->unzip_me($ct);
6505     } else {
6506         $self->{was_uncompressed}++ unless $ct->gtest();
6507         $local_file = $self->handle_singlefile($local_file);
6508     }
6509
6510     # we are still in the tmp directory!
6511     # Let's check if the package has its own directory.
6512     my $dh = DirHandle->new(File::Spec->curdir)
6513         or Carp::croak("Couldn't opendir .: $!");
6514     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6515     if (grep { $_ eq "pax_global_header" } @readdir) {
6516         $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
6517 from the tarball '$local_file'.
6518 This is almost certainly an error. Please upgrade your tar.
6519 I'll ignore this file for now.
6520 See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
6521         $CPAN::Frontend->mysleep(5);
6522         @readdir = grep { $_ ne "pax_global_header" } @readdir;
6523     }
6524     $dh->close;
6525     my ($packagedir);
6526     # XXX here we want in each branch File::Temp to protect all build_dir directories
6527     if (CPAN->has_usable("File::Temp")) {
6528         my $tdir_base;
6529         my $from_dir;
6530         my @dirents;
6531         if (@readdir == 1 && -d $readdir[0]) {
6532             $tdir_base = $readdir[0];
6533             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6534             my $dh2;
6535             unless ($dh2 = DirHandle->new($from_dir)) {
6536                 my($mode) = (stat $from_dir)[2];
6537                 my $why = sprintf
6538                     (
6539                      "Couldn't opendir '%s', mode '%o': %s",
6540                      $from_dir,
6541                      $mode,
6542                      $!,
6543                     );
6544                 $CPAN::Frontend->mywarn("$why\n");
6545                 $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
6546                 return;
6547             }
6548             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6549         } else {
6550             my $userid = $self->cpan_userid;
6551             CPAN->debug("userid[$userid]");
6552             if (!$userid or $userid eq "N/A") {
6553                 $userid = "anon";
6554             }
6555             $tdir_base = $userid;
6556             $from_dir = File::Spec->curdir;
6557             @dirents = @readdir;
6558         }
6559         $packagedir = File::Temp::tempdir(
6560                                           "$tdir_base-XXXXXX",
6561                                           DIR => $builddir,
6562                                           CLEANUP => 0,
6563                                          );
6564         my $f;
6565         for $f (@dirents) { # is already without "." and ".."
6566             my $from = File::Spec->catdir($from_dir,$f);
6567             my $to = File::Spec->catdir($packagedir,$f);
6568             unless (File::Copy::move($from,$to)) {
6569                 my $err = $!;
6570                 $from = File::Spec->rel2abs($from);
6571                 Carp::confess("Couldn't move $from to $to: $err");
6572             }
6573         }
6574     } else { # older code below, still better than nothing when there is no File::Temp
6575         my($distdir);
6576         if (@readdir == 1 && -d $readdir[0]) {
6577             $distdir = $readdir[0];
6578             $packagedir = File::Spec->catdir($builddir,$distdir);
6579             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6580                 if $CPAN::DEBUG;
6581             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6582                                                         "$packagedir\n");
6583             File::Path::rmtree($packagedir);
6584             unless (File::Copy::move($distdir,$packagedir)) {
6585                 $CPAN::Frontend->unrecoverable_error(<<EOF);
6586 Couldn't move '$distdir' to '$packagedir': $!
6587
6588 Cannot continue: Please find the reason why I cannot move
6589 $builddir/tmp-$$/$distdir
6590 to
6591 $packagedir
6592 and fix the problem, then retry
6593
6594 EOF
6595             }
6596             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6597                                  $distdir,
6598                                  $packagedir,
6599                                  -e $packagedir,
6600                                  -d $packagedir,
6601                                 )) if $CPAN::DEBUG;
6602         } else {
6603             my $userid = $self->cpan_userid;
6604             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6605             if (!$userid or $userid eq "N/A") {
6606                 $userid = "anon";
6607             }
6608             my $pragmatic_dir = $userid . '000';
6609             $pragmatic_dir =~ s/\W_//g;
6610             $pragmatic_dir++ while -d "../$pragmatic_dir";
6611             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6612             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6613             File::Path::mkpath($packagedir);
6614             my($f);
6615             for $f (@readdir) { # is already without "." and ".."
6616                 my $to = File::Spec->catdir($packagedir,$f);
6617                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6618             }
6619         }
6620     }
6621     $self->{build_dir} = $packagedir;
6622     $self->safe_chdir($builddir);
6623     File::Path::rmtree("tmp-$$");
6624
6625     $self->safe_chdir($packagedir);
6626     $self->_signature_business();
6627     $self->safe_chdir($builddir);
6628
6629     return($packagedir,$local_file);
6630 }
6631
6632 #-> sub CPAN::Distribution::parse_meta_yml ;
6633 sub parse_meta_yml {
6634     my($self) = @_;
6635     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6636     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6637     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6638     return unless -f $yaml;
6639     my $early_yaml;
6640     eval {
6641         require Parse::Metayaml; # hypothetical
6642         $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6643     };
6644     unless ($early_yaml) {
6645         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6646     }
6647     unless ($early_yaml) {
6648         return;
6649     }
6650     return $early_yaml;
6651 }
6652
6653 #-> sub CPAN::Distribution::satisfy_requires ;
6654 sub satisfy_requires {
6655     my ($self) = @_;
6656     if (my @prereq = $self->unsat_prereq("later")) {
6657         if ($prereq[0][0] eq "perl") {
6658             my $need = "requires perl '$prereq[0][1]'";
6659             my $id = $self->pretty_id;
6660             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6661             $self->{make} = CPAN::Distrostatus->new("NO $need");
6662             $self->store_persistent_state;
6663             die "[prereq] -- NOT OK\n";
6664         } else {
6665             my $follow = eval { $self->follow_prereqs("later",@prereq); };
6666             if (0) {
6667             } elsif ($follow) {
6668                 # signal success to the queuerunner
6669                 return 1;
6670             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6671                 $CPAN::Frontend->mywarn($@);
6672                 die "[depend] -- NOT OK\n";
6673             }
6674         }
6675     }
6676 }
6677
6678 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6679 sub satisfy_configure_requires {
6680     my($self) = @_;
6681     my $enable_configure_requires = 1;
6682     if (!$enable_configure_requires) {
6683         return 1;
6684         # if we return 1 here, everything is as before we introduced
6685         # configure_requires that means, things with
6686         # configure_requires simply fail, all others succeed
6687     }
6688     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6689     if ($self->{configure_requires_later}) {
6690         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6691             if ($self->{configure_requires_later_for}{$k}>1) {
6692                 # we must not come here a second time
6693                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6694                 require YAML::Syck;
6695                 $CPAN::Frontend->mydie
6696                     (
6697                      YAML::Syck::Dump
6698                      ({self=>$self, prereq=>\@prereq})
6699                     );
6700             }
6701         }
6702     }
6703     if ($prereq[0][0] eq "perl") {
6704         my $need = "requires perl '$prereq[0][1]'";
6705         my $id = $self->pretty_id;
6706         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6707         $self->{make} = CPAN::Distrostatus->new("NO $need");
6708         $self->store_persistent_state;
6709         return $self->goodbye("[prereq] -- NOT OK");
6710     } else {
6711         my $follow = eval {
6712             $self->follow_prereqs("configure_requires_later", @prereq);
6713         };
6714         if (0) {
6715         } elsif ($follow) {
6716             return;
6717         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6718             $CPAN::Frontend->mywarn($@);
6719             return $self->goodbye("[depend] -- NOT OK");
6720         }
6721     }
6722     die "never reached";
6723 }
6724
6725 #-> sub CPAN::Distribution::choose_MM_or_MB ;
6726 sub choose_MM_or_MB {
6727     my($self,$local_file) = @_;
6728     $self->satisfy_configure_requires() or return;
6729     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6730     my($mpl_exists) = -f $mpl;
6731     unless ($mpl_exists) {
6732         # NFS has been reported to have racing problems after the
6733         # renaming of a directory in some environments.
6734         # This trick helps.
6735         $CPAN::Frontend->mysleep(1);
6736         my $mpldh = DirHandle->new($self->{build_dir})
6737             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6738         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6739         $mpldh->close;
6740     }
6741     my $prefer_installer = "eumm"; # eumm|mb
6742     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6743         if ($mpl_exists) { # they *can* choose
6744             if ($CPAN::META->has_inst("Module::Build")) {
6745                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6746                                                                      q{prefer_installer});
6747             }
6748         } else {
6749             $prefer_installer = "mb";
6750         }
6751     }
6752     return unless $self->patch;
6753     if (lc($prefer_installer) eq "rand") {
6754         $prefer_installer = rand()<.5 ? "eumm" : "mb";
6755     }
6756     if (lc($prefer_installer) eq "mb") {
6757         $self->{modulebuild} = 1;
6758     } elsif ($self->{archived} eq "patch") {
6759         # not an edge case, nothing to install for sure
6760         my $why = "A patch file cannot be installed";
6761         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6762         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6763     } elsif (! $mpl_exists) {
6764         $self->_edge_cases($mpl,$local_file);
6765     }
6766     if ($self->{build_dir}
6767         &&
6768         $CPAN::Config->{build_dir_reuse}
6769        ) {
6770         $self->store_persistent_state;
6771     }
6772     return $self;
6773 }
6774
6775 #-> CPAN::Distribution::store_persistent_state
6776 sub store_persistent_state {
6777     my($self) = @_;
6778     my $dir = $self->{build_dir};
6779     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6780             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6781         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6782                                 "will not store persistent state\n");
6783         return;
6784     }
6785     my $file = sprintf "%s.yml", $dir;
6786     my $yaml_module = CPAN::_yaml_module;
6787     if ($CPAN::META->has_inst($yaml_module)) {
6788         CPAN->_yaml_dumpfile(
6789                              $file,
6790                              {
6791                               time => time,
6792                               perl => CPAN::_perl_fingerprint,
6793                               distribution => $self,
6794                              }
6795                             );
6796     } else {
6797         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6798                                 "will not store persistent state\n");
6799     }
6800 }
6801
6802 #-> CPAN::Distribution::try_download
6803 sub try_download {
6804     my($self,$patch) = @_;
6805     my $norm = $self->normalize($patch);
6806     my($local_wanted) =
6807         File::Spec->catfile(
6808                             $CPAN::Config->{keep_source_where},
6809                             "authors",
6810                             "id",
6811                             split(/\//,$norm),
6812                            );
6813     $self->debug("Doing localize") if $CPAN::DEBUG;
6814     return CPAN::FTP->localize("authors/id/$norm",
6815                                $local_wanted);
6816 }
6817
6818 {
6819     my $stdpatchargs = "";
6820     #-> CPAN::Distribution::patch
6821     sub patch {
6822         my($self) = @_;
6823         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6824         my $patches = $self->prefs->{patches};
6825         $patches ||= "";
6826         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6827         if ($patches) {
6828             return unless @$patches;
6829             $self->safe_chdir($self->{build_dir});
6830             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6831             my $patchbin = $CPAN::Config->{patch};
6832             unless ($patchbin && length $patchbin) {
6833                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6834                                        "Please run 'o conf init /patch/'\n\n");
6835             }
6836             unless (MM->maybe_command($patchbin)) {
6837                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6838                                        "Please run 'o conf init /patch/'\n\n");
6839             }
6840             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6841             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6842             unless ($stdpatchargs) {
6843                 my $system = "$patchbin --version |";
6844                 local *FH;
6845                 open FH, $system or die "Could not fork '$system': $!";
6846                 local $/ = "\n";
6847                 my $pversion;
6848               PARSEVERSION: while (<FH>) {
6849                     if (/^patch\s+([\d\.]+)/) {
6850                         $pversion = $1;
6851                         last PARSEVERSION;
6852                     }
6853                 }
6854                 if ($pversion) {
6855                     $stdpatchargs = "-N --fuzz=3";
6856                 } else {
6857                     $stdpatchargs = "-N";
6858                 }
6859             }
6860             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6861             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6862             for my $patch (@$patches) {
6863                 unless (-f $patch) {
6864                     if (my $trydl = $self->try_download($patch)) {
6865                         $patch = $trydl;
6866                     } else {
6867                         my $fail = "Could not find patch '$patch'";
6868                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6869                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6870                         delete $self->{build_dir};
6871                         return;
6872                     }
6873                 }
6874                 $CPAN::Frontend->myprint("  $patch\n");
6875                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6876
6877                 my $pcommand;
6878                 my $ppp = $self->_patch_p_parameter($readfh);
6879                 if ($ppp eq "applypatch") {
6880                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6881                 } else {
6882                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6883                     $pcommand = "$patchbin $thispatchargs";
6884                 }
6885
6886                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6887                 my $writefh = FileHandle->new;
6888                 $CPAN::Frontend->myprint("  $pcommand\n");
6889                 unless (open $writefh, "|$pcommand") {
6890                     my $fail = "Could not fork '$pcommand'";
6891                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6892                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6893                     delete $self->{build_dir};
6894                     return;
6895                 }
6896                 while (my $x = $readfh->READLINE) {
6897                     print $writefh $x;
6898                 }
6899                 unless (close $writefh) {
6900                     my $fail = "Could not apply patch '$patch'";
6901                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6902                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6903                     delete $self->{build_dir};
6904                     return;
6905                 }
6906             }
6907             $self->{patched}++;
6908         }
6909         return 1;
6910     }
6911 }
6912
6913 sub _patch_p_parameter {
6914     my($self,$fh) = @_;
6915     my $cnt_files   = 0;
6916     my $cnt_p0files = 0;
6917     local($_);
6918     while ($_ = $fh->READLINE) {
6919         if (
6920             $CPAN::Config->{applypatch}
6921             &&
6922             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6923            ) {
6924             return "applypatch"
6925         }
6926         next unless /^[\*\+]{3}\s(\S+)/;
6927         my $file = $1;
6928         $cnt_files++;
6929         $cnt_p0files++ if -f $file;
6930         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6931             if $CPAN::DEBUG;
6932     }
6933     return "-p1" unless $cnt_files;
6934     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6935 }
6936
6937 #-> sub CPAN::Distribution::_edge_cases
6938 # with "configure" or "Makefile" or single file scripts
6939 sub _edge_cases {
6940     my($self,$mpl,$local_file) = @_;
6941     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6942                          $mpl,
6943                          CPAN::anycwd(),
6944                         )) if $CPAN::DEBUG;
6945     my $build_dir = $self->{build_dir};
6946     my($configure) = File::Spec->catfile($build_dir,"Configure");
6947     if (-f $configure) {
6948         # do we have anything to do?
6949         $self->{configure} = $configure;
6950     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6951         $CPAN::Frontend->mywarn(qq{
6952 Package comes with a Makefile and without a Makefile.PL.
6953 We\'ll try to build it with that Makefile then.
6954 });
6955         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6956         $CPAN::Frontend->mysleep(2);
6957     } else {
6958         my $cf = $self->called_for || "unknown";
6959         if ($cf =~ m|/|) {
6960             $cf =~ s|.*/||;
6961             $cf =~ s|\W.*||;
6962         }
6963         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6964         $cf = "unknown" unless length($cf);
6965         if (my $crap = $self->_contains_crap($build_dir)) {
6966             my $why = qq{Package contains $crap; not recognized as a perl package, giving up};
6967             $CPAN::Frontend->mywarn("$why\n");
6968             $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
6969             return;
6970         }
6971         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6972   (The test -f "$mpl" returned false.)
6973   Writing one on our own (setting NAME to $cf)\a\n});
6974         $self->{had_no_makefile_pl}++;
6975         $CPAN::Frontend->mysleep(3);
6976
6977         # Writing our own Makefile.PL
6978
6979         my $exefile_stanza = "";
6980         if ($self->{archived} eq "maybe_pl") {
6981             $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
6982         }
6983
6984         my $fh = FileHandle->new;
6985         $fh->open(">$mpl")
6986             or Carp::croak("Could not open >$mpl: $!");
6987         $fh->print(
6988                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6989 # because there was no Makefile.PL supplied.
6990 # Autogenerated on: }.scalar localtime().qq{
6991
6992 use ExtUtils::MakeMaker;
6993 WriteMakefile(
6994               NAME => q[$cf],$exefile_stanza
6995              );
6996 });
6997         $fh->close;
6998     }
6999 }
7000
7001 #-> CPAN;:Distribution::_contains_crap
7002 sub _contains_crap {
7003     my($self,$dir) = @_;
7004     my(@dirs, $dh, @files);
7005     opendir $dh, $dir or return;
7006     my $dirent;
7007     for $dirent (readdir $dh) {
7008         next if $dirent =~ /^\.\.?$/;
7009         my $path = File::Spec->catdir($dir,$dirent);
7010         if (-d $path) {
7011             push @dirs, $dirent;
7012         } elsif (-f $path) {
7013             push @files, $dirent;
7014         }
7015     }
7016     if (@dirs && @files) {
7017         return "both files[@files] and directories[@dirs]";
7018     } elsif (@files > 2) {
7019         return "several files[@files] but no Makefile.PL or Build.PL";
7020     }
7021     return;
7022 }
7023
7024 #-> CPAN;:Distribution::_exefile_stanza
7025 sub _exefile_stanza {
7026     my($self,$build_dir,$local_file) = @_;
7027
7028             my $fh = FileHandle->new;
7029             my $script_file = File::Spec->catfile($build_dir,$local_file);
7030             $fh->open($script_file)
7031                 or Carp::croak("Could not open script '$script_file': $!");
7032             local $/ = "\n";
7033             # name parsen und prereq
7034             my($state) = "poddir";
7035             my($name, $prereq) = ("", "");
7036             while (<$fh>) {
7037                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
7038                     if ($1 eq 'NAME') {
7039                         $state = "name";
7040                     } elsif ($1 eq 'PREREQUISITES') {
7041                         $state = "prereq";
7042                     }
7043                 } elsif ($state =~ m{^(name|prereq)$}) {
7044                     if (/^=/) {
7045                         $state = "poddir";
7046                     } elsif (/^\s*$/) {
7047                         # nop
7048                     } elsif ($state eq "name") {
7049                         if ($name eq "") {
7050                             ($name) = /^(\S+)/;
7051                             $state = "poddir";
7052                         }
7053                     } elsif ($state eq "prereq") {
7054                         $prereq .= $_;
7055                     }
7056                 } elsif (/^=cut\b/) {
7057                     last;
7058                 }
7059             }
7060             $fh->close;
7061
7062             for ($name) {
7063                 s{.*<}{};       # strip X<...>
7064                 s{>.*}{};
7065             }
7066             chomp $prereq;
7067             $prereq = join " ", split /\s+/, $prereq;
7068             my($PREREQ_PM) = join("\n", map {
7069                 s{.*<}{};       # strip X<...>
7070                 s{>.*}{};
7071                 if (/[\s\'\"]/) { # prose?
7072                 } else {
7073                     s/[^\w:]$//; # period?
7074                     " "x28 . "'$_' => 0,";
7075                 }
7076             } split /\s*,\s*/, $prereq);
7077
7078             if ($name) {
7079                 my $to_file = File::Spec->catfile($build_dir, $name);
7080                 rename $script_file, $to_file
7081                     or die "Can't rename $script_file to $to_file: $!";
7082             }
7083
7084     return "
7085               EXE_FILES => ['$name'],
7086               PREREQ_PM => {
7087 $PREREQ_PM
7088                            },
7089 ";
7090 }
7091
7092 #-> CPAN::Distribution::_signature_business
7093 sub _signature_business {
7094     my($self) = @_;
7095     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7096                                                       q{check_sigs});
7097     if ($check_sigs) {
7098         if ($CPAN::META->has_inst("Module::Signature")) {
7099             if (-f "SIGNATURE") {
7100                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7101                 my $rv = Module::Signature::verify();
7102                 if ($rv != Module::Signature::SIGNATURE_OK() and
7103                     $rv != Module::Signature::SIGNATURE_MISSING()) {
7104                     $CPAN::Frontend->mywarn(
7105                                             qq{\nSignature invalid for }.
7106                                             qq{distribution file. }.
7107                                             qq{Please investigate.\n\n}
7108                                            );
7109
7110                     my $wrap =
7111                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
7112                                 qq{while checking its signature, so it could        }.
7113                                 qq{be invalid. Maybe you have configured            }.
7114                                 qq{your 'urllist' with a bad URL. Please check this }.
7115                                 qq{array with 'o conf urllist' and retry. Or        }.
7116                                 qq{examine the distribution in a subshell. Try
7117   look %s
7118 and run
7119   cpansign -v
7120 },
7121                                 $self->{localfile},
7122                                 $self->pretty_id,
7123                                );
7124                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
7125                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
7126                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
7127                 } else {
7128                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
7129                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
7130                 }
7131             } else {
7132                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
7133             }
7134         } else {
7135             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7136         }
7137     }
7138 }
7139
7140 #-> CPAN::Distribution::untar_me ;
7141 sub untar_me {
7142     my($self,$ct) = @_;
7143     $self->{archived} = "tar";
7144     my $result = eval { $ct->untar() };
7145     if ($result) {
7146         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7147     } else {
7148         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
7149     }
7150 }
7151
7152 # CPAN::Distribution::unzip_me ;
7153 sub unzip_me {
7154     my($self,$ct) = @_;
7155     $self->{archived} = "zip";
7156     if ($ct->unzip()) {
7157         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7158     } else {
7159         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
7160     }
7161     return;
7162 }
7163
7164 sub handle_singlefile {
7165     my($self,$local_file) = @_;
7166
7167     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
7168         $self->{archived} = "pm";
7169     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
7170         $self->{archived} = "patch";
7171     } else {
7172         $self->{archived} = "maybe_pl";
7173     }
7174
7175     my $to = File::Basename::basename($local_file);
7176     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
7177         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
7178             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7179         } else {
7180             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
7181         }
7182     } else {
7183         if (File::Copy::cp($local_file,".")) {
7184             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7185         } else {
7186             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
7187         }
7188     }
7189     return $to;
7190 }
7191
7192 #-> sub CPAN::Distribution::new ;
7193 sub new {
7194     my($class,%att) = @_;
7195
7196     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
7197
7198     my $this = { %att };
7199     return bless $this, $class;
7200 }
7201
7202 #-> sub CPAN::Distribution::look ;
7203 sub look {
7204     my($self) = @_;
7205
7206     if ($^O eq 'MacOS') {
7207       $self->Mac::BuildTools::look;
7208       return;
7209     }
7210
7211     if (  $CPAN::Config->{'shell'} ) {
7212         $CPAN::Frontend->myprint(qq{
7213 Trying to open a subshell in the build directory...
7214 });
7215     } else {
7216         $CPAN::Frontend->myprint(qq{
7217 Your configuration does not define a value for subshells.
7218 Please define it with "o conf shell <your shell>"
7219 });
7220         return;
7221     }
7222     my $dist = $self->id;
7223     my $dir;
7224     unless ($dir = $self->dir) {
7225         $self->get;
7226     }
7227     unless ($dir ||= $self->dir) {
7228         $CPAN::Frontend->mywarn(qq{
7229 Could not determine which directory to use for looking at $dist.
7230 });
7231         return;
7232     }
7233     my $pwd  = CPAN::anycwd();
7234     $self->safe_chdir($dir);
7235     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
7236     {
7237         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
7238         $ENV{CPAN_SHELL_LEVEL} += 1;
7239         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
7240
7241         local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7242             ? $ENV{PERL5LIB}
7243                 : ($ENV{PERLLIB} || "");
7244
7245         local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
7246         $CPAN::META->set_perl5lib;
7247         local $ENV{MAKEFLAGS}; # protect us from outer make calls
7248
7249         unless (system($shell) == 0) {
7250             my $code = $? >> 8;
7251             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
7252         }
7253     }
7254     $self->safe_chdir($pwd);
7255 }
7256
7257 # CPAN::Distribution::cvs_import ;
7258 sub cvs_import {
7259     my($self) = @_;
7260     $self->get;
7261     my $dir = $self->dir;
7262
7263     my $package = $self->called_for;
7264     my $module = $CPAN::META->instance('CPAN::Module', $package);
7265     my $version = $module->cpan_version;
7266
7267     my $userid = $self->cpan_userid;
7268
7269     my $cvs_dir = (split /\//, $dir)[-1];
7270     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
7271     my $cvs_root =
7272       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
7273     my $cvs_site_perl =
7274       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
7275     if ($cvs_site_perl) {
7276         $cvs_dir = "$cvs_site_perl/$cvs_dir";
7277     }
7278     my $cvs_log = qq{"imported $package $version sources"};
7279     $version =~ s/\./_/g;
7280     # XXX cvs: undocumented and unclear how it was meant to work
7281     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
7282                "$cvs_dir", $userid, "v$version");
7283
7284     my $pwd  = CPAN::anycwd();
7285     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
7286
7287     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
7288
7289     $CPAN::Frontend->myprint(qq{@cmd\n});
7290     system(@cmd) == 0 or
7291     # XXX cvs
7292         $CPAN::Frontend->mydie("cvs import failed");
7293     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
7294 }
7295
7296 #-> sub CPAN::Distribution::readme ;
7297 sub readme {
7298     my($self) = @_;
7299     my($dist) = $self->id;
7300     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
7301     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
7302     my($local_file);
7303     my($local_wanted) =
7304         File::Spec->catfile(
7305                             $CPAN::Config->{keep_source_where},
7306                             "authors",
7307                             "id",
7308                             split(/\//,"$sans.readme"),
7309                            );
7310     $self->debug("Doing localize") if $CPAN::DEBUG;
7311     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
7312                                       $local_wanted)
7313         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
7314
7315     if ($^O eq 'MacOS') {
7316         Mac::BuildTools::launch_file($local_file);
7317         return;
7318     }
7319
7320     my $fh_pager = FileHandle->new;
7321     local($SIG{PIPE}) = "IGNORE";
7322     my $pager = $CPAN::Config->{'pager'} || "cat";
7323     $fh_pager->open("|$pager")
7324         or die "Could not open pager $pager\: $!";
7325     my $fh_readme = FileHandle->new;
7326     $fh_readme->open($local_file)
7327         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
7328     $CPAN::Frontend->myprint(qq{
7329 Displaying file
7330   $local_file
7331 with pager "$pager"
7332 });
7333     $fh_pager->print(<$fh_readme>);
7334     $fh_pager->close;
7335 }
7336
7337 #-> sub CPAN::Distribution::verifyCHECKSUM ;
7338 sub verifyCHECKSUM {
7339     my($self) = @_;
7340   EXCUSE: {
7341         my @e;
7342         $self->{CHECKSUM_STATUS} ||= "";
7343         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
7344         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7345     }
7346     my($lc_want,$lc_file,@local,$basename);
7347     @local = split(/\//,$self->id);
7348     pop @local;
7349     push @local, "CHECKSUMS";
7350     $lc_want =
7351         File::Spec->catfile($CPAN::Config->{keep_source_where},
7352                             "authors", "id", @local);
7353     local($") = "/";
7354     if (my $size = -s $lc_want) {
7355         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7356         if ($self->CHECKSUM_check_file($lc_want,1)) {
7357             return $self->{CHECKSUM_STATUS} = "OK";
7358         }
7359     }
7360     $lc_file = CPAN::FTP->localize("authors/id/@local",
7361                                    $lc_want,1);
7362     unless ($lc_file) {
7363         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7364         $local[-1] .= ".gz";
7365         $lc_file = CPAN::FTP->localize("authors/id/@local",
7366                                        "$lc_want.gz",1);
7367         if ($lc_file) {
7368             $lc_file =~ s/\.gz(?!\n)\Z//;
7369             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7370         } else {
7371             return;
7372         }
7373     }
7374     if ($self->CHECKSUM_check_file($lc_file)) {
7375         return $self->{CHECKSUM_STATUS} = "OK";
7376     }
7377 }
7378
7379 #-> sub CPAN::Distribution::SIG_check_file ;
7380 sub SIG_check_file {
7381     my($self,$chk_file) = @_;
7382     my $rv = eval { Module::Signature::_verify($chk_file) };
7383
7384     if ($rv == Module::Signature::SIGNATURE_OK()) {
7385         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7386         return $self->{SIG_STATUS} = "OK";
7387     } else {
7388         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7389                                  qq{distribution file. }.
7390                                  qq{Please investigate.\n\n}.
7391                                  $self->as_string,
7392                                  $CPAN::META->instance(
7393                                                        'CPAN::Author',
7394                                                        $self->cpan_userid
7395                                                       )->as_string);
7396
7397         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7398 is invalid. Maybe you have configured your 'urllist' with
7399 a bad URL. Please check this array with 'o conf urllist', and
7400 retry.};
7401
7402         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7403     }
7404 }
7405
7406 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7407
7408 # sloppy is 1 when we have an old checksums file that maybe is good
7409 # enough
7410
7411 sub CHECKSUM_check_file {
7412     my($self,$chk_file,$sloppy) = @_;
7413     my($cksum,$file,$basename);
7414
7415     $sloppy ||= 0;
7416     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7417     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7418                                                       q{check_sigs});
7419     if ($check_sigs) {
7420         if ($CPAN::META->has_inst("Module::Signature")) {
7421             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7422             $self->SIG_check_file($chk_file);
7423         } else {
7424             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7425         }
7426     }
7427
7428     $file = $self->{localfile};
7429     $basename = File::Basename::basename($file);
7430     my $fh = FileHandle->new;
7431     if (open $fh, $chk_file) {
7432         local($/);
7433         my $eval = <$fh>;
7434         $eval =~ s/\015?\012/\n/g;
7435         close $fh;
7436         my($compmt) = Safe->new();
7437         $cksum = $compmt->reval($eval);
7438         if ($@) {
7439             rename $chk_file, "$chk_file.bad";
7440             Carp::confess($@) if $@;
7441         }
7442     } else {
7443         Carp::carp "Could not open $chk_file for reading";
7444     }
7445
7446     if (! ref $cksum or ref $cksum ne "HASH") {
7447         $CPAN::Frontend->mywarn(qq{
7448 Warning: checksum file '$chk_file' broken.
7449
7450 When trying to read that file I expected to get a hash reference
7451 for further processing, but got garbage instead.
7452 });
7453         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7454         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7455         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7456         return;
7457     } elsif (exists $cksum->{$basename}{sha256}) {
7458         $self->debug("Found checksum for $basename:" .
7459                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7460
7461         open($fh, $file);
7462         binmode $fh;
7463         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7464         $fh->close;
7465         $fh = CPAN::Tarzip->TIEHANDLE($file);
7466
7467         unless ($eq) {
7468             my $dg = Digest::SHA->new(256);
7469             my($data,$ref);
7470             $ref = \$data;
7471             while ($fh->READ($ref, 4096) > 0) {
7472                 $dg->add($data);
7473             }
7474             my $hexdigest = $dg->hexdigest;
7475             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7476         }
7477
7478         if ($eq) {
7479             $CPAN::Frontend->myprint("Checksum for $file ok\n");
7480             return $self->{CHECKSUM_STATUS} = "OK";
7481         } else {
7482             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7483                                      qq{distribution file. }.
7484                                      qq{Please investigate.\n\n}.
7485                                      $self->as_string,
7486                                      $CPAN::META->instance(
7487                                                            'CPAN::Author',
7488                                                            $self->cpan_userid
7489                                                           )->as_string);
7490
7491             my $wrap = qq{I\'d recommend removing $file. Its
7492 checksum is incorrect. Maybe you have configured your 'urllist' with
7493 a bad URL. Please check this array with 'o conf urllist', and
7494 retry.};
7495
7496             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7497
7498             # former versions just returned here but this seems a
7499             # serious threat that deserves a die
7500
7501             # $CPAN::Frontend->myprint("\n\n");
7502             # sleep 3;
7503             # return;
7504         }
7505         # close $fh if fileno($fh);
7506     } else {
7507         return if $sloppy;
7508         unless ($self->{CHECKSUM_STATUS}) {
7509             $CPAN::Frontend->mywarn(qq{
7510 Warning: No checksum for $basename in $chk_file.
7511
7512 The cause for this may be that the file is very new and the checksum
7513 has not yet been calculated, but it may also be that something is
7514 going awry right now.
7515 });
7516             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7517             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7518         }
7519         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7520         return;
7521     }
7522 }
7523
7524 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7525 sub eq_CHECKSUM {
7526     my($self,$fh,$expect) = @_;
7527     if ($CPAN::META->has_inst("Digest::SHA")) {
7528         my $dg = Digest::SHA->new(256);
7529         my($data);
7530         while (read($fh, $data, 4096)) {
7531             $dg->add($data);
7532         }
7533         my $hexdigest = $dg->hexdigest;
7534         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7535         return $hexdigest eq $expect;
7536     }
7537     return 1;
7538 }
7539
7540 #-> sub CPAN::Distribution::force ;
7541
7542 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7543 # effect by autoinspection, not by inspecting a global variable. One
7544 # of the reason why this was chosen to work that way was the treatment
7545 # of dependencies. They should not automatically inherit the force
7546 # status. But this has the downside that ^C and die() will return to
7547 # the prompt but will not be able to reset the force_update
7548 # attributes. We try to correct for it currently in the read_metadata
7549 # routine, and immediately before we check for a Signal. I hope this
7550 # works out in one of v1.57_53ff
7551
7552 # "Force get forgets previous error conditions"
7553
7554 #-> sub CPAN::Distribution::fforce ;
7555 sub fforce {
7556   my($self, $method) = @_;
7557   $self->force($method,1);
7558 }
7559
7560 #-> sub CPAN::Distribution::force ;
7561 sub force {
7562   my($self, $method,$fforce) = @_;
7563   my %phase_map = (
7564                    get => [
7565                            "unwrapped",
7566                            "build_dir",
7567                            "archived",
7568                            "localfile",
7569                            "CHECKSUM_STATUS",
7570                            "signature_verify",
7571                            "prefs",
7572                            "prefs_file",
7573                            "prefs_file_doc",
7574                           ],
7575                    make => [
7576                             "writemakefile",
7577                             "make",
7578                             "modulebuild",
7579                             "prereq_pm",
7580                             "prereq_pm_detected",
7581                            ],
7582                    test => [
7583                             "badtestcnt",
7584                             "make_test",
7585                            ],
7586                    install => [
7587                                "install",
7588                               ],
7589                    unknown => [
7590                                "reqtype",
7591                                "yaml_content",
7592                               ],
7593                   );
7594   my $methodmatch = 0;
7595   my $ldebug = 0;
7596  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7597       $methodmatch = 1 if $fforce || $phase eq $method;
7598       next unless $methodmatch;
7599     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7600           if ($phase eq "get") {
7601               if (substr($self->id,-1,1) eq "."
7602                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
7603                   # cannot be undone for local distros
7604                   next ATTRIBUTE;
7605               }
7606               if ($att eq "build_dir"
7607                   && $self->{build_dir}
7608                   && $CPAN::META->{is_tested}
7609                  ) {
7610                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
7611               }
7612           } elsif ($phase eq "test") {
7613               if ($att eq "make_test"
7614                   && $self->{make_test}
7615                   && $self->{make_test}{COMMANDID}
7616                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7617                  ) {
7618                   # endless loop too likely
7619                   next ATTRIBUTE;
7620               }
7621           }
7622           delete $self->{$att};
7623           if ($ldebug || $CPAN::DEBUG) {
7624               # local $CPAN::DEBUG = 16; # Distribution
7625               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7626           }
7627       }
7628   }
7629   if ($method && $method =~ /make|test|install/) {
7630     $self->{force_update} = 1; # name should probably have been force_install
7631   }
7632 }
7633
7634 #-> sub CPAN::Distribution::notest ;
7635 sub notest {
7636   my($self, $method) = @_;
7637   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7638   $self->{"notest"}++; # name should probably have been force_install
7639 }
7640
7641 #-> sub CPAN::Distribution::unnotest ;
7642 sub unnotest {
7643   my($self) = @_;
7644   # warn "XDEBUG: deleting notest";
7645   delete $self->{notest};
7646 }
7647
7648 #-> sub CPAN::Distribution::unforce ;
7649 sub unforce {
7650   my($self) = @_;
7651   delete $self->{force_update};
7652 }
7653
7654 #-> sub CPAN::Distribution::isa_perl ;
7655 sub isa_perl {
7656   my($self) = @_;
7657   my $file = File::Basename::basename($self->id);
7658   if ($file =~ m{ ^ perl
7659                   -?
7660                   (5)
7661                   ([._-])
7662                   (
7663                    \d{3}(_[0-4][0-9])?
7664                    |
7665                    \d+\.\d+
7666                   )
7667                   \.tar[._-](?:gz|bz2)
7668                   (?!\n)\Z
7669                 }xs) {
7670     return "$1.$3";
7671   } elsif ($self->cpan_comment
7672            &&
7673            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7674     return $1;
7675   }
7676 }
7677
7678
7679 #-> sub CPAN::Distribution::perl ;
7680 sub perl {
7681     my ($self) = @_;
7682     if (! $self) {
7683         use Carp qw(carp);
7684         carp __PACKAGE__ . "::perl was called without parameters.";
7685     }
7686     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7687 }
7688
7689
7690 #-> sub CPAN::Distribution::make ;
7691 sub make {
7692     my($self) = @_;
7693     if (my $goto = $self->prefs->{goto}) {
7694         return $self->goto($goto);
7695     }
7696     my $make = $self->{modulebuild} ? "Build" : "make";
7697     # Emergency brake if they said install Pippi and get newest perl
7698     if ($self->isa_perl) {
7699         if (
7700             $self->called_for ne $self->id &&
7701             ! $self->{force_update}
7702         ) {
7703             # if we die here, we break bundles
7704             $CPAN::Frontend
7705                 ->mywarn(sprintf(
7706                             qq{The most recent version "%s" of the module "%s"
7707 is part of the perl-%s distribution. To install that, you need to run
7708   force install %s   --or--
7709   install %s
7710 },
7711                              $CPAN::META->instance(
7712                                                    'CPAN::Module',
7713                                                    $self->called_for
7714                                                   )->cpan_version,
7715                              $self->called_for,
7716                              $self->isa_perl,
7717                              $self->called_for,
7718                              $self->id,
7719                             ));
7720             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7721             $CPAN::Frontend->mysleep(1);
7722             return;
7723         }
7724     }
7725     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7726     $self->get;
7727     return if $self->prefs->{disabled} && ! $self->{force_update};
7728     if ($self->{configure_requires_later}) {
7729         return;
7730     }
7731     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7732                            ? $ENV{PERL5LIB}
7733                            : ($ENV{PERLLIB} || "");
7734     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
7735     $CPAN::META->set_perl5lib;
7736     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7737
7738     if ($CPAN::Signal) {
7739         delete $self->{force_update};
7740         return;
7741     }
7742
7743     my $builddir;
7744   EXCUSE: {
7745         my @e;
7746         if (!$self->{archived} || $self->{archived} eq "NO") {
7747             push @e, "Is neither a tar nor a zip archive.";
7748         }
7749
7750         if (!$self->{unwrapped}
7751             || (
7752                 UNIVERSAL::can($self->{unwrapped},"failed") ?
7753                 $self->{unwrapped}->failed :
7754                 $self->{unwrapped} =~ /^NO/
7755                )) {
7756             push @e, "Had problems unarchiving. Please build manually";
7757         }
7758
7759         unless ($self->{force_update}) {
7760             exists $self->{signature_verify} and
7761                 (
7762                  UNIVERSAL::can($self->{signature_verify},"failed") ?
7763                  $self->{signature_verify}->failed :
7764                  $self->{signature_verify} =~ /^NO/
7765                 )
7766                 and push @e, "Did not pass the signature test.";
7767         }
7768
7769         if (exists $self->{writemakefile} &&
7770             (
7771              UNIVERSAL::can($self->{writemakefile},"failed") ?
7772              $self->{writemakefile}->failed :
7773              $self->{writemakefile} =~ /^NO/
7774             )) {
7775             # XXX maybe a retry would be in order?
7776             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7777                 $self->{writemakefile}->text :
7778                     $self->{writemakefile};
7779             $err =~ s/^NO\s*(--\s+)?//;
7780             $err ||= "Had some problem writing Makefile";
7781             $err .= ", won't make";
7782             push @e, $err;
7783         }
7784
7785         if (defined $self->{make}) {
7786             if (UNIVERSAL::can($self->{make},"failed") ?
7787                 $self->{make}->failed :
7788                 $self->{make} =~ /^NO/) {
7789                 if ($self->{force_update}) {
7790                     # Trying an already failed 'make' (unless somebody else blocks)
7791                 } else {
7792                     # introduced for turning recursion detection into a distrostatus
7793                     my $error = length $self->{make}>3
7794                         ? substr($self->{make},3) : "Unknown error";
7795                     $CPAN::Frontend->mywarn("Could not make: $error\n");
7796                     $self->store_persistent_state;
7797                     return;
7798                 }
7799             } else {
7800                 push @e, "Has already been made";
7801                 my $wait_for_prereqs = eval { $self->satisfy_requires };
7802                 return 1 if $wait_for_prereqs;   # tells queuerunner to continue
7803                 return $self->goodbye($@) if $@; # tells queuerunner to stop
7804             }
7805         }
7806
7807         my $later = $self->{later} || $self->{configure_requires_later};
7808         if ($later) { # see also undelay
7809             if ($later) {
7810                 push @e, $later;
7811             }
7812         }
7813
7814         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7815         $builddir = $self->dir or
7816             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7817         unless (chdir $builddir) {
7818             push @e, "Couldn't chdir to '$builddir': $!";
7819         }
7820         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7821     }
7822     if ($CPAN::Signal) {
7823         delete $self->{force_update};
7824         return;
7825     }
7826     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7827     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7828
7829     if ($^O eq 'MacOS') {
7830         Mac::BuildTools::make($self);
7831         return;
7832     }
7833
7834     my %env;
7835     while (my($k,$v) = each %ENV) {
7836         next unless defined $v;
7837         $env{$k} = $v;
7838     }
7839     local %ENV = %env;
7840     my $system;
7841     my $pl_commandline;
7842     if ($self->prefs->{pl}) {
7843         $pl_commandline = $self->prefs->{pl}{commandline};
7844     }
7845     if ($pl_commandline) {
7846         $system = $pl_commandline;
7847         $ENV{PERL} = $^X;
7848     } elsif ($self->{'configure'}) {
7849         $system = $self->{'configure'};
7850     } elsif ($self->{modulebuild}) {
7851         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7852         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7853     } else {
7854         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7855         my $switch = "";
7856 # This needs a handler that can be turned on or off:
7857 #        $switch = "-MExtUtils::MakeMaker ".
7858 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7859 #            if $] > 5.00310;
7860         my $makepl_arg = $self->_make_phase_arg("pl");
7861         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7862                                                             "Makefile.PL");
7863         $system = sprintf("%s%s Makefile.PL%s",
7864                           $perl,
7865                           $switch ? " $switch" : "",
7866                           $makepl_arg ? " $makepl_arg" : "",
7867                          );
7868     }
7869     my $pl_env;
7870     if ($self->prefs->{pl}) {
7871         $pl_env = $self->prefs->{pl}{env};
7872     }
7873     if ($pl_env) {
7874         for my $e (keys %$pl_env) {
7875             $ENV{$e} = $pl_env->{$e};
7876         }
7877     }
7878     if (exists $self->{writemakefile}) {
7879     } else {
7880         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7881         my($ret,$pid,$output);
7882         $@ = "";
7883         my $go_via_alarm;
7884         if ($CPAN::Config->{inactivity_timeout}) {
7885             require Config;
7886             if ($Config::Config{d_alarm}
7887                 &&
7888                 $Config::Config{d_alarm} eq "define"
7889                ) {
7890                 $go_via_alarm++
7891             } else {
7892                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7893                                         "variable 'inactivity_timeout' to ".
7894                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7895                                         "on this machine the system call 'alarm' ".
7896                                         "isn't available. This means that we cannot ".
7897                                         "provide the feature of intercepting long ".
7898                                         "waiting code and will turn this feature off.\n"
7899                                        );
7900                 $CPAN::Config->{inactivity_timeout} = 0;
7901             }
7902         }
7903         if ($go_via_alarm) {
7904             if ( $self->_should_report('pl') ) {
7905                 ($output, $ret) = CPAN::Reporter::record_command(
7906                     $system,
7907                     $CPAN::Config->{inactivity_timeout},
7908                 );
7909                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7910             }
7911             else {
7912                 eval {
7913                     alarm $CPAN::Config->{inactivity_timeout};
7914                     local $SIG{CHLD}; # = sub { wait };
7915                     if (defined($pid = fork)) {
7916                         if ($pid) { #parent
7917                             # wait;
7918                             waitpid $pid, 0;
7919                         } else {    #child
7920                             # note, this exec isn't necessary if
7921                             # inactivity_timeout is 0. On the Mac I'd
7922                             # suggest, we set it always to 0.
7923                             exec $system;
7924                         }
7925                     } else {
7926                         $CPAN::Frontend->myprint("Cannot fork: $!");
7927                         return;
7928                     }
7929                 };
7930                 alarm 0;
7931                 if ($@) {
7932                     kill 9, $pid;
7933                     waitpid $pid, 0;
7934                     my $err = "$@";
7935                     $CPAN::Frontend->myprint($err);
7936                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7937                     $@ = "";
7938                     $self->store_persistent_state;
7939                     return $self->goodbye("$system -- TIMED OUT");
7940                 }
7941             }
7942         } else {
7943             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7944                 # XXX probably want to check _should_report here and warn
7945                 # about not being able to use CPAN::Reporter with expect
7946                 $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
7947                 if (! defined $ret
7948                     && $self->{writemakefile}
7949                     && $self->{writemakefile}->failed) {
7950                     # timeout
7951                     return;
7952                 }
7953             }
7954             elsif ( $self->_should_report('pl') ) {
7955                 ($output, $ret) = CPAN::Reporter::record_command($system);
7956                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7957             }
7958             else {
7959                 $ret = system($system);
7960             }
7961             if ($ret != 0) {
7962                 $self->{writemakefile} = CPAN::Distrostatus
7963                     ->new("NO '$system' returned status $ret");
7964                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7965                 $self->store_persistent_state;
7966                 return $self->goodbye("$system -- NOT OK");
7967             }
7968         }
7969         if (-f "Makefile" || -f "Build") {
7970             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7971             delete $self->{make_clean}; # if cleaned before, enable next
7972         } else {
7973             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7974             my $why = "No '$makefile' created";
7975             $CPAN::Frontend->mywarn($why);
7976             $self->{writemakefile} = CPAN::Distrostatus
7977                 ->new(qq{NO -- $why\n});
7978             $self->store_persistent_state;
7979             return $self->goodbye("$system -- NOT OK");
7980         }
7981     }
7982     if ($CPAN::Signal) {
7983         delete $self->{force_update};
7984         return;
7985     }
7986     my $wait_for_prereqs = eval { $self->satisfy_requires };
7987     return 1 if $wait_for_prereqs;   # tells queuerunner to continue
7988     return $self->goodbye($@) if $@; # tells queuerunner to stop
7989     if ($CPAN::Signal) {
7990         delete $self->{force_update};
7991         return;
7992     }
7993     my $make_commandline;
7994     if ($self->prefs->{make}) {
7995         $make_commandline = $self->prefs->{make}{commandline};
7996     }
7997     if ($make_commandline) {
7998         $system = $make_commandline;
7999         $ENV{PERL} = CPAN::find_perl;
8000     } else {
8001         if ($self->{modulebuild}) {
8002             unless (-f "Build") {
8003                 my $cwd = CPAN::anycwd();
8004                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
8005                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
8006                 $CPAN::Frontend->mysleep(5);
8007             }
8008             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
8009         } else {
8010             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
8011         }
8012         $system =~ s/\s+$//;
8013         my $make_arg = $self->_make_phase_arg("make");
8014         $system = sprintf("%s%s",
8015                           $system,
8016                           $make_arg ? " $make_arg" : "",
8017                          );
8018     }
8019     my $make_env;
8020     if ($self->prefs->{make}) {
8021         $make_env = $self->prefs->{make}{env};
8022     }
8023     if ($make_env) { # overriding the local ENV of PL, not the outer
8024                      # ENV, but unlikely to be a risk
8025         for my $e (keys %$make_env) {
8026             $ENV{$e} = $make_env->{$e};
8027         }
8028     }
8029     my $expect_model = $self->_prefs_with_expect("make");
8030     my $want_expect = 0;
8031     if ( $expect_model && @{$expect_model->{talk}} ) {
8032         my $can_expect = $CPAN::META->has_inst("Expect");
8033         if ($can_expect) {
8034             $want_expect = 1;
8035         } else {
8036             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8037                                     "system()\n");
8038         }
8039     }
8040     my $system_ok;
8041     if ($want_expect) {
8042         # XXX probably want to check _should_report here and
8043         # warn about not being able to use CPAN::Reporter with expect
8044         $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
8045     }
8046     elsif ( $self->_should_report('make') ) {
8047         my ($output, $ret) = CPAN::Reporter::record_command($system);
8048         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
8049         $system_ok = ! $ret;
8050     }
8051     else {
8052         $system_ok = system($system) == 0;
8053     }
8054     $self->introduce_myself;
8055     if ( $system_ok ) {
8056         $CPAN::Frontend->myprint("  $system -- OK\n");
8057         $self->{make} = CPAN::Distrostatus->new("YES");
8058     } else {
8059         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
8060         $self->{make} = CPAN::Distrostatus->new("NO");
8061         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8062     }
8063     $self->store_persistent_state;
8064 }
8065
8066 # CPAN::Distribution::goodbye ;
8067 sub goodbye {
8068     my($self,$goodbye) = @_;
8069     my $id = $self->pretty_id;
8070     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
8071     return;
8072 }
8073
8074 # CPAN::Distribution::_run_via_expect ;
8075 sub _run_via_expect {
8076     my($self,$system,$phase,$expect_model) = @_;
8077     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
8078     if ($CPAN::META->has_inst("Expect")) {
8079         my $expo = Expect->new;  # expo Expect object;
8080         $expo->spawn($system);
8081         $expect_model->{mode} ||= "deterministic";
8082         if ($expect_model->{mode} eq "deterministic") {
8083             return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
8084         } elsif ($expect_model->{mode} eq "anyorder") {
8085             return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
8086         } else {
8087             die "Panic: Illegal expect mode: $expect_model->{mode}";
8088         }
8089     } else {
8090         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
8091         return system($system);
8092     }
8093 }
8094
8095 sub _run_via_expect_anyorder {
8096     my($self,$expo,$phase,$expect_model) = @_;
8097     my $timeout = $expect_model->{timeout} || 5;
8098     my $reuse = $expect_model->{reuse};
8099     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
8100     my $but = "";
8101     my $timeout_start = time;
8102   EXPECT: while () {
8103         my($eof,$ran_into_timeout);
8104         # XXX not up to the full power of expect. one could certainly
8105         # wrap all of the talk pairs into a single expect call and on
8106         # success tweak it and step ahead to the next question. The
8107         # current implementation unnecessarily limits itself to a
8108         # single match.
8109         my @match = $expo->expect(1,
8110                                   [ eof => sub {
8111                                         $eof++;
8112                                     } ],
8113                                   [ timeout => sub {
8114                                         $ran_into_timeout++;
8115                                     } ],
8116                                   -re => eval"qr{.}",
8117                                  );
8118         if ($match[2]) {
8119             $but .= $match[2];
8120         }
8121         $but .= $expo->clear_accum;
8122         if ($eof) {
8123             $expo->soft_close;
8124             return $expo->exitstatus();
8125         } elsif ($ran_into_timeout) {
8126             # warn "DEBUG: they are asking a question, but[$but]";
8127             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
8128                 my($next,$send) = @expectacopy[$i,$i+1];
8129                 my $regex = eval "qr{$next}";
8130                 # warn "DEBUG: will compare with regex[$regex].";
8131                 if ($but =~ /$regex/) {
8132                     # warn "DEBUG: will send send[$send]";
8133                     $expo->send($send);
8134                     # never allow reusing an QA pair unless they told us
8135                     splice @expectacopy, $i, 2 unless $reuse;
8136                     next EXPECT;
8137                 }
8138             }
8139             my $have_waited = time - $timeout_start;
8140             if ($have_waited < $timeout) {
8141                 # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
8142                 next EXPECT;
8143             }
8144             my $why = "could not answer a question during the dialog";
8145             $CPAN::Frontend->mywarn("Failing: $why\n");
8146             $self->{$phase} =
8147                 CPAN::Distrostatus->new("NO $why");
8148             return 0;
8149         }
8150     }
8151 }
8152
8153 sub _run_via_expect_deterministic {
8154     my($self,$expo,$phase,$expect_model) = @_;
8155     my $ran_into_timeout;
8156     my $ran_into_eof;
8157     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
8158     my $expecta = $expect_model->{talk};
8159   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
8160         my($re,$send) = @$expecta[$i,$i+1];
8161         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
8162         my $regex = eval "qr{$re}";
8163         $expo->expect($timeout,
8164                       [ eof => sub {
8165                             my $but = $expo->clear_accum;
8166                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
8167 expected[$regex]\nbut[$but]\n\n");
8168                             $ran_into_eof++;
8169                         } ],
8170                       [ timeout => sub {
8171                             my $but = $expo->clear_accum;
8172                             $CPAN::Frontend->mywarn("TIMEOUT
8173 expected[$regex]\nbut[$but]\n\n");
8174                             $ran_into_timeout++;
8175                         } ],
8176                       -re => $regex);
8177         if ($ran_into_timeout) {
8178             # note that the caller expects 0 for success
8179             $self->{$phase} =
8180                 CPAN::Distrostatus->new("NO timeout during expect dialog");
8181             return 0;
8182         } elsif ($ran_into_eof) {
8183             last EXPECT;
8184         }
8185         $expo->send($send);
8186     }
8187     $expo->soft_close;
8188     return $expo->exitstatus();
8189 }
8190
8191 #-> CPAN::Distribution::_validate_distropref
8192 sub _validate_distropref {
8193     my($self,@args) = @_;
8194     if (
8195         $CPAN::META->has_inst("CPAN::Kwalify")
8196         &&
8197         $CPAN::META->has_inst("Kwalify")
8198        ) {
8199         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
8200         if ($@) {
8201             $CPAN::Frontend->mywarn($@);
8202         }
8203     } else {
8204         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
8205     }
8206 }
8207
8208 #-> CPAN::Distribution::_find_prefs
8209 sub _find_prefs {
8210     my($self) = @_;
8211     my $distroid = $self->pretty_id;
8212     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
8213     my $prefs_dir = $CPAN::Config->{prefs_dir};
8214     return if $prefs_dir =~ /^\s*$/;
8215     eval { File::Path::mkpath($prefs_dir); };
8216     if ($@) {
8217         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
8218     }
8219     my $yaml_module = CPAN::_yaml_module;
8220     my $ext_map = {};
8221     my @extensions;
8222     if ($CPAN::META->has_inst($yaml_module)) {
8223         $ext_map->{yml} = 'CPAN';
8224     } else {
8225         my @fallbacks;
8226         if ($CPAN::META->has_inst("Data::Dumper")) {
8227             push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
8228         }
8229         if ($CPAN::META->has_inst("Storable")) {
8230             push @fallbacks, $ext_map->{st} = 'Storable';
8231         }
8232         if (@fallbacks) {
8233             local $" = " and ";
8234             unless ($self->{have_complained_about_missing_yaml}++) {
8235                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
8236                                         "to @fallbacks to read prefs '$prefs_dir'\n");
8237             }
8238         } else {
8239             unless ($self->{have_complained_about_missing_yaml}++) {
8240                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
8241                                         "read prefs '$prefs_dir'\n");
8242             }
8243         }
8244     }
8245     my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
8246     DIRENT: while (my $result = $finder->next) {
8247         if ($result->is_warning) {
8248             $CPAN::Frontend->mywarn($result->as_string);
8249             $CPAN::Frontend->mysleep(1);
8250             next DIRENT;
8251         } elsif ($result->is_fatal) {
8252             $CPAN::Frontend->mydie($result->as_string);
8253         }
8254
8255         my @prefs = @{ $result->prefs };
8256
8257       ELEMENT: for my $y (0..$#prefs) {
8258             my $pref = $prefs[$y];
8259             $self->_validate_distropref($pref->data, $result->abs, $y);
8260
8261             # I don't know why we silently skip when there's no match, but
8262             # complain if there's an empty match hashref, and there's no
8263             # comment explaining why -- hdp, 2008-03-18
8264             unless ($pref->has_any_match) {
8265                 next ELEMENT;
8266             }
8267
8268             unless ($pref->has_valid_subkeys) {
8269                 $CPAN::Frontend->mydie(sprintf
8270                     "Nonconforming .%s file '%s': " .
8271                     "missing match/* subattribute. " .
8272                     "Please remove, cannot continue.",
8273                     $result->ext, $result->abs,
8274                 );
8275             }
8276
8277             my $arg = {
8278                 env          => \%ENV,
8279                 distribution => $distroid,
8280                 perl         => \&CPAN::find_perl,
8281                 perlconfig   => \%Config::Config,
8282                 module       => sub { [ $self->containsmods ] },
8283             };
8284
8285             if ($pref->matches($arg)) {
8286                 return {
8287                     prefs => $pref->data,
8288                     prefs_file => $result->abs,
8289                     prefs_file_doc => $y,
8290                 };
8291             }
8292
8293         }
8294     }
8295     return;
8296 }
8297
8298 # CPAN::Distribution::prefs
8299 sub prefs {
8300     my($self) = @_;
8301     if (exists $self->{negative_prefs_cache}
8302         &&
8303         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8304        ) {
8305         delete $self->{negative_prefs_cache};
8306         delete $self->{prefs};
8307     }
8308     if (exists $self->{prefs}) {
8309         return $self->{prefs}; # XXX comment out during debugging
8310     }
8311     if ($CPAN::Config->{prefs_dir}) {
8312         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8313         my $prefs = $self->_find_prefs();
8314         $prefs ||= ""; # avoid warning next line
8315         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8316         if ($prefs) {
8317             for my $x (qw(prefs prefs_file prefs_file_doc)) {
8318                 $self->{$x} = $prefs->{$x};
8319             }
8320             my $bs = sprintf(
8321                              "%s[%s]",
8322                              File::Basename::basename($self->{prefs_file}),
8323                              $self->{prefs_file_doc},
8324                             );
8325             my $filler1 = "_" x 22;
8326             my $filler2 = int(66 - length($bs))/2;
8327             $filler2 = 0 if $filler2 < 0;
8328             $filler2 = " " x $filler2;
8329             $CPAN::Frontend->myprint("
8330 $filler1 D i s t r o P r e f s $filler1
8331 $filler2 $bs $filler2
8332 ");
8333             $CPAN::Frontend->mysleep(1);
8334             return $self->{prefs};
8335         }
8336     }
8337     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8338     return $self->{prefs} = +{};
8339 }
8340
8341 # CPAN::Distribution::_make_phase_arg
8342 sub _make_phase_arg {
8343     my($self, $phase) = @_;
8344     my $_make_phase_arg;
8345     my $prefs = $self->prefs;
8346     if (
8347         $prefs
8348         && exists $prefs->{$phase}
8349         && exists $prefs->{$phase}{args}
8350         && $prefs->{$phase}{args}
8351        ) {
8352         $_make_phase_arg = join(" ",
8353                            map {CPAN::HandleConfig
8354                                  ->safe_quote($_)} @{$prefs->{$phase}{args}},
8355                           );
8356     }
8357
8358 # cpan[2]> o conf make[TAB]
8359 # make                       make_install_make_command
8360 # make_arg                   makepl_arg
8361 # make_install_arg
8362 # cpan[2]> o conf mbuild[TAB]
8363 # mbuild_arg                    mbuild_install_build_command
8364 # mbuild_install_arg            mbuildpl_arg
8365
8366     my $mantra; # must switch make/mbuild here
8367     if ($self->{modulebuild}) {
8368         $mantra = "mbuild";
8369     } else {
8370         $mantra = "make";
8371     }
8372     my %map = (
8373                pl => "pl_arg",
8374                make => "_arg",
8375                test => "_test_arg", # does not really exist but maybe
8376                                     # will some day and now protects
8377                                     # us from unini warnings
8378                install => "_install_arg",
8379               );
8380     my $phase_underscore_meshup = $map{$phase};
8381     my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
8382
8383     $_make_phase_arg ||= $CPAN::Config->{$what};
8384     return $_make_phase_arg;
8385 }
8386
8387 # CPAN::Distribution::_make_command
8388 sub _make_command {
8389     my ($self) = @_;
8390     if ($self) {
8391         return
8392             CPAN::HandleConfig
8393                 ->safe_quote(
8394                              CPAN::HandleConfig->prefs_lookup($self,
8395                                                               q{make})
8396                              || $Config::Config{make}
8397                              || 'make'
8398                             );
8399     } else {
8400         # Old style call, without object. Deprecated
8401         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8402         return
8403           safe_quote(undef,
8404                      CPAN::HandleConfig->prefs_lookup($self,q{make})
8405                      || $CPAN::Config->{make}
8406                      || $Config::Config{make}
8407                      || 'make');
8408     }
8409 }
8410
8411 #-> sub CPAN::Distribution::follow_prereqs ;
8412 sub follow_prereqs {
8413     my($self) = shift;
8414     my($slot) = shift;
8415     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8416     return unless @prereq_tuples;
8417     my(@good_prereq_tuples);
8418     for my $p (@prereq_tuples) {
8419         # XXX watch out for foul ones
8420         # $DB::single++;
8421         push @good_prereq_tuples, $p;
8422     }
8423     my $pretty_id = $self->pretty_id;
8424     my %map = (
8425                b => "build_requires",
8426                r => "requires",
8427                c => "commandline",
8428               );
8429     my($filler1,$filler2,$filler3,$filler4);
8430     my $unsat = "Unsatisfied dependencies detected during";
8431     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8432     {
8433         my $r = int(($w - length($unsat))/2);
8434         my $l = $w - length($unsat) - $r;
8435         $filler1 = "-"x4 . " "x$l;
8436         $filler2 = " "x$r . "-"x4 . "\n";
8437     }
8438     {
8439         my $r = int(($w - length($pretty_id))/2);
8440         my $l = $w - length($pretty_id) - $r;
8441         $filler3 = "-"x4 . " "x$l;
8442         $filler4 = " "x$r . "-"x4 . "\n";
8443     }
8444     $CPAN::Frontend->
8445         myprint("$filler1 $unsat $filler2".
8446                 "$filler3 $pretty_id $filler4".
8447                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
8448                );
8449     my $follow = 0;
8450     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8451         $follow = 1;
8452     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8453         my $answer = CPAN::Shell::colorable_makemaker_prompt(
8454 "Shall I follow them and prepend them to the queue
8455 of modules we are processing right now?", "yes");
8456         $follow = $answer =~ /^\s*y/i;
8457     } else {
8458         my @prereq = map { $_=>[0] } @good_prereq_tuples;
8459         local($") = ", ";
8460         $CPAN::Frontend->
8461             myprint("  Ignoring dependencies on modules @prereq\n");
8462     }
8463     if ($follow) {
8464         my $id = $self->id;
8465         # color them as dirty
8466         for my $gp (@good_prereq_tuples) {
8467             # warn "calling color_cmd_tmps(0,1)";
8468             my $p = $gp->[0];
8469             my $any = CPAN::Shell->expandany($p);
8470             $self->{$slot . "_for"}{$any->id}++;
8471             if ($any) {
8472                 $any->color_cmd_tmps(0,2);
8473             } else {
8474                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8475                 $CPAN::Frontend->mysleep(2);
8476             }
8477         }
8478         # queue them and re-queue yourself
8479         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8480                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
8481         $self->{$slot} = "Delayed until after prerequisites";
8482         return 1; # signal success to the queuerunner
8483     }
8484     return;
8485 }
8486
8487 sub _feature_depends {
8488     my($self) = @_;
8489     my $meta_yml = $self->parse_meta_yml();
8490     my $optf = $meta_yml->{optional_features} or return;
8491     if (!ref $optf or ref $optf ne "HASH"){
8492         $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
8493         $optf = {};
8494     }
8495     my $wantf = $self->prefs->{features} or return;
8496     if (!ref $wantf or ref $wantf ne "ARRAY"){
8497         $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
8498         $wantf = [];
8499     }
8500     my $dep = +{};
8501     for my $wf (@$wantf) {
8502         if (my $f = $optf->{$wf}) {
8503             $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
8504                                      "is accompanied by this description:\n".
8505                                      $f->{description}.
8506                                      "\n\n"
8507                                     );
8508             # configure_requires currently not in the spec, unlikely to be useful anyway
8509             for my $reqtype (qw(configure_requires build_requires requires)) {
8510                 my $reqhash = $f->{$reqtype} or next;
8511                 while (my($k,$v) = each %$reqhash) {
8512                     $dep->{$reqtype}{$k} = $v;
8513                 }
8514             }
8515         } else {
8516             $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
8517                                     "found in the META.yml file".
8518                                     "\n\n"
8519                                    );
8520         }
8521     }
8522     $dep;
8523 }
8524
8525 #-> sub CPAN::Distribution::unsat_prereq ;
8526 # return ([Foo,"r"],[Bar,"b"]) for normal modules
8527 # return ([perl=>5.008]) if we need a newer perl than we are running under
8528 # (sorry for the inconsistency, it was an accident)
8529 sub unsat_prereq {
8530     my($self,$slot) = @_;
8531     my(%merged,$prereq_pm);
8532     my $prefs_depends = $self->prefs->{depends}||{};
8533     my $feature_depends = $self->_feature_depends();
8534     if ($slot eq "configure_requires_later") {
8535         my $meta_yml = $self->parse_meta_yml();
8536         if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
8537             $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
8538             $meta_yml = +{};
8539         }
8540         %merged = (
8541                    %{$meta_yml->{configure_requires}||{}},
8542                    %{$prefs_depends->{configure_requires}||{}},
8543                    %{$feature_depends->{configure_requires}||{}},
8544                   );
8545         $prereq_pm = {}; # configure_requires defined as "b"
8546     } elsif ($slot eq "later") {
8547         my $prereq_pm_0 = $self->prereq_pm || {};
8548         for my $reqtype (qw(requires build_requires)) {
8549             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8550             for my $dep ($prefs_depends,$feature_depends) {
8551                 for my $k (keys %{$dep->{$reqtype}||{}}) {
8552                     $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
8553                 }
8554             }
8555         }
8556         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8557     } else {
8558         die "Panic: illegal slot '$slot'";
8559     }
8560     my(@need);
8561     my @merged = %merged;
8562     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8563   NEED: while (my($need_module, $need_version) = each %merged) {
8564         my($available_version,$available_file,$nmo);
8565         if ($need_module eq "perl") {
8566             $available_version = $];
8567             $available_file = CPAN::find_perl;
8568         } else {
8569             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8570             next if $nmo->uptodate;
8571             $available_file = $nmo->available_file;
8572
8573             # if they have not specified a version, we accept any installed one
8574             if (defined $available_file
8575                 and ( # a few quick shortcurcuits
8576                      not defined $need_version
8577                      or $need_version eq '0'    # "==" would trigger warning when not numeric
8578                      or $need_version eq "undef"
8579                     )) {
8580                 next NEED;
8581             }
8582
8583             $available_version = $nmo->available_version;
8584         }
8585
8586         # We only want to install prereqs if either they're not installed
8587         # or if the installed version is too old. We cannot omit this
8588         # check, because if 'force' is in effect, nobody else will check.
8589         if (defined $available_file) {
8590             my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
8591                 ($need_module,$available_file,$available_version,$need_version);
8592             next NEED if $fulfills_all_version_rqs;
8593         }
8594
8595         if ($need_module eq "perl") {
8596             return ["perl", $need_version];
8597         }
8598         $self->{sponsored_mods}{$need_module} ||= 0;
8599         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8600         if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
8601             # We have already sponsored it and for some reason it's still
8602             # not available. So we do ... what??
8603
8604             # if we push it again, we have a potential infinite loop
8605
8606             # The following "next" was a very problematic construct.
8607             # It helped a lot but broke some day and had to be
8608             # replaced.
8609
8610             # We must be able to deal with modules that come again and
8611             # again as a prereq and have themselves prereqs and the
8612             # queue becomes long but finally we would find the correct
8613             # order. The RecursiveDependency check should trigger a
8614             # die when it's becoming too weird. Unfortunately removing
8615             # this next breaks many other things.
8616
8617             # The bug that brought this up is described in Todo under
8618             # "5.8.9 cannot install Compress::Zlib"
8619
8620             # next; # this is the next that had to go away
8621
8622             # The following "next NEED" are fine and the error message
8623             # explains well what is going on. For example when the DBI
8624             # fails and consequently DBD::SQLite fails and now we are
8625             # processing CPAN::SQLite. Then we must have a "next" for
8626             # DBD::SQLite. How can we get it and how can we identify
8627             # all other cases we must identify?
8628
8629             my $do = $nmo->distribution;
8630             next NEED unless $do; # not on CPAN
8631             if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
8632                 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8633                                         "'$need_module => $need_version' ".
8634                                         "for '$self->{ID}' seems ".
8635                                         "not available according to the indexes\n"
8636                                        );
8637                 next NEED;
8638             }
8639           NOSAYER: for my $nosayer (
8640                                     "unwrapped",
8641                                     "writemakefile",
8642                                     "signature_verify",
8643                                     "make",
8644                                     "make_test",
8645                                     "install",
8646                                     "make_clean",
8647                                    ) {
8648                 if ($do->{$nosayer}) {
8649                     my $selfid = $self->pretty_id;
8650                     my $did = $do->pretty_id;
8651                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8652                         $do->{$nosayer}->failed :
8653                         $do->{$nosayer} =~ /^NO/) {
8654                         if ($nosayer eq "make_test"
8655                             &&
8656                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8657                            ) {
8658                             next NOSAYER;
8659                         }
8660                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8661                                                 "'$need_module => $need_version' ".
8662                                                 "for '$selfid' failed when ".
8663                                                 "processing '$did' with ".
8664                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8665                                                 "but chances to succeed are limited.\n"
8666                                                );
8667                         $CPAN::Frontend->mysleep($sponsoring/10);
8668                         next NEED;
8669                     } else { # the other guy succeeded
8670                         if ($nosayer =~ /^(install|make_test)$/) {
8671                             # we had this with
8672                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8673                             # in 2007-03 for 'make install'
8674                             # and 2008-04: #30464 (for 'make test')
8675                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8676                                                     "'$need_module => $need_version' ".
8677                                                     "for '$selfid' already built ".
8678                                                     "but the result looks suspicious. ".
8679                                                     "Skipping another build attempt, ".
8680                                                     "to prevent looping endlessly.\n"
8681                                                    );
8682                             next NEED;
8683                         }
8684                     }
8685                 }
8686             }
8687         }
8688         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8689         push @need, [$need_module,$needed_as];
8690     }
8691     my @unfolded = map { "[".join(",",@$_)."]" } @need;
8692     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8693     @need;
8694 }
8695
8696 sub _fulfills_all_version_rqs {
8697     my($self,$need_module,$available_file,$available_version,$need_version) = @_;
8698     my(@all_requirements) = split /\s*,\s*/, $need_version;
8699     local($^W) = 0;
8700     my $ok = 0;
8701   RQ: for my $rq (@all_requirements) {
8702         if ($rq =~ s|>=\s*||) {
8703         } elsif ($rq =~ s|>\s*||) {
8704             # 2005-12: one user
8705             if (CPAN::Version->vgt($available_version,$rq)) {
8706                 $ok++;
8707             }
8708             next RQ;
8709         } elsif ($rq =~ s|!=\s*||) {
8710             # 2005-12: no user
8711             if (CPAN::Version->vcmp($available_version,$rq)) {
8712                 $ok++;
8713                 next RQ;
8714             } else {
8715                 last RQ;
8716             }
8717         } elsif ($rq =~ m|<=?\s*|) {
8718             # 2005-12: no user
8719             $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8720             $ok++;
8721             next RQ;
8722         }
8723         if (! CPAN::Version->vgt($rq, $available_version)) {
8724             $ok++;
8725         }
8726         CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8727                             "available_version[%s]rq[%s]ok[%d]",
8728                             $need_module,
8729                             $available_file,
8730                             $available_version,
8731                             CPAN::Version->readable($rq),
8732                             $ok,
8733                            )) if $CPAN::DEBUG;
8734     }
8735     return $ok == @all_requirements;
8736 }
8737
8738 #-> sub CPAN::Distribution::read_yaml ;
8739 sub read_yaml {
8740     my($self) = @_;
8741     return $self->{yaml_content} if exists $self->{yaml_content};
8742     my $build_dir;
8743     unless ($build_dir = $self->{build_dir}) {
8744         # maybe permission on build_dir was missing
8745         $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
8746         return;
8747     }
8748     my $yaml = File::Spec->catfile($build_dir,"META.yml");
8749     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8750     return unless -f $yaml;
8751     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8752     if ($@) {
8753         $CPAN::Frontend->mywarn("Could not read ".
8754                                 "'$yaml'. Falling back to other ".
8755                                 "methods to determine prerequisites\n");
8756         return $self->{yaml_content} = undef; # if we die, then we
8757                                               # cannot read YAML's own
8758                                               # META.yml
8759     }
8760     # not "authoritative"
8761     for ($self->{yaml_content}) {
8762         if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
8763             $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
8764             $self->{yaml_content} = +{};
8765         }
8766     }
8767     if (not exists $self->{yaml_content}{dynamic_config}
8768         or $self->{yaml_content}{dynamic_config}
8769        ) {
8770         $self->{yaml_content} = undef;
8771     }
8772     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8773         if $CPAN::DEBUG;
8774     return $self->{yaml_content};
8775 }
8776
8777 #-> sub CPAN::Distribution::prereq_pm ;
8778 sub prereq_pm {
8779     my($self) = @_;
8780     $self->{prereq_pm_detected} ||= 0;
8781     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8782     return $self->{prereq_pm} if $self->{prereq_pm_detected};
8783     return unless $self->{writemakefile}  # no need to have succeeded
8784                                           # but we must have run it
8785         || $self->{modulebuild};
8786     unless ($self->{build_dir}) {
8787         return;
8788     }
8789     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8790                 $self->{writemakefile}||"",
8791                 $self->{modulebuild}||"",
8792                ) if $CPAN::DEBUG;
8793     my($req,$breq);
8794     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8795         $req =  $yaml->{requires} || {};
8796         $breq =  $yaml->{build_requires} || {};
8797         undef $req unless ref $req eq "HASH" && %$req;
8798         if ($req) {
8799             if ($yaml->{generated_by} &&
8800                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8801                 my $eummv = do { local $^W = 0; $1+0; };
8802                 if ($eummv < 6.2501) {
8803                     # thanks to Slaven for digging that out: MM before
8804                     # that could be wrong because it could reflect a
8805                     # previous release
8806                     undef $req;
8807                 }
8808             }
8809             my $areq;
8810             my $do_replace;
8811             while (my($k,$v) = each %{$req||{}}) {
8812                 if ($v =~ /\d/) {
8813                     $areq->{$k} = $v;
8814                 } elsif ($k =~ /[A-Za-z]/ &&
8815                          $v =~ /[A-Za-z]/ &&
8816                          $CPAN::META->exists("Module",$v)
8817                         ) {
8818                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8819                                             "requires hash: $k => $v; I'll take both ".
8820                                             "key and value as a module name\n");
8821                     $CPAN::Frontend->mysleep(1);
8822                     $areq->{$k} = 0;
8823                     $areq->{$v} = 0;
8824                     $do_replace++;
8825                 }
8826             }
8827             $req = $areq if $do_replace;
8828         }
8829     }
8830     unless ($req || $breq) {
8831         my $build_dir;
8832         unless ( $build_dir = $self->{build_dir} ) {
8833             return;
8834         }
8835         my $makefile = File::Spec->catfile($build_dir,"Makefile");
8836         my $fh;
8837         if (-f $makefile
8838             and
8839             $fh = FileHandle->new("<$makefile\0")) {
8840             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8841             local($/) = "\n";
8842             while (<$fh>) {
8843                 last if /MakeMaker post_initialize section/;
8844                 my($p) = m{^[\#]
8845                            \s+PREREQ_PM\s+=>\s+(.+)
8846                        }x;
8847                 next unless $p;
8848                 # warn "Found prereq expr[$p]";
8849
8850                 #  Regexp modified by A.Speer to remember actual version of file
8851                 #  PREREQ_PM hash key wants, then add to
8852                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8853                     # In case a prereq is mentioned twice, complain.
8854                     if ( defined $req->{$1} ) {
8855                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
8856                             "last mention wins";
8857                     }
8858                     my($m,$n) = ($1,$2);
8859                     if ($n =~ /^q\[(.*?)\]$/) {
8860                         $n = $1;
8861                     }
8862                     $req->{$m} = $n;
8863                 }
8864                 last;
8865             }
8866         }
8867     }
8868     unless ($req || $breq) {
8869         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8870         my $buildfile = File::Spec->catfile($build_dir,"Build");
8871         if (-f $buildfile) {
8872             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8873             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8874             if (-f $build_prereqs) {
8875                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8876                 my $content = do { local *FH;
8877                                    open FH, $build_prereqs
8878                                        or $CPAN::Frontend->mydie("Could not open ".
8879                                                                  "'$build_prereqs': $!");
8880                                    local $/;
8881                                    <FH>;
8882                                };
8883                 my $bphash = eval $content;
8884                 if ($@) {
8885                 } else {
8886                     $req  = $bphash->{requires} || +{};
8887                     $breq = $bphash->{build_requires} || +{};
8888                 }
8889             }
8890         }
8891     }
8892     if (-f "Build.PL"
8893         && ! -f "Makefile.PL"
8894         && ! exists $req->{"Module::Build"}
8895         && ! $CPAN::META->has_inst("Module::Build")) {
8896         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8897                                 "undeclared prerequisite.\n".
8898                                 "  Adding it now as such.\n"
8899                                );
8900         $CPAN::Frontend->mysleep(5);
8901         $req->{"Module::Build"} = 0;
8902         delete $self->{writemakefile};
8903     }
8904     if ($req || $breq) {
8905         $self->{prereq_pm_detected}++;
8906         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8907     }
8908 }
8909
8910 #-> sub CPAN::Distribution::test ;
8911 sub test {
8912     my($self) = @_;
8913     if (my $goto = $self->prefs->{goto}) {
8914         return $self->goto($goto);
8915     }
8916     $self->make;
8917     return if $self->prefs->{disabled} && ! $self->{force_update};
8918     if ($CPAN::Signal) {
8919       delete $self->{force_update};
8920       return;
8921     }
8922     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8923     if ($self->{notest}) {
8924         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8925         return 1;
8926     }
8927
8928     my $make = $self->{modulebuild} ? "Build" : "make";
8929
8930     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8931                            ? $ENV{PERL5LIB}
8932                            : ($ENV{PERLLIB} || "");
8933
8934     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
8935     $CPAN::META->set_perl5lib;
8936     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8937
8938     $CPAN::Frontend->myprint("Running $make test\n");
8939
8940   EXCUSE: {
8941         my @e;
8942         if ($self->{make} or $self->{later}) {
8943             # go ahead
8944         } else {
8945             push @e,
8946                 "Make had some problems, won't test";
8947         }
8948
8949         exists $self->{make} and
8950             (
8951              UNIVERSAL::can($self->{make},"failed") ?
8952              $self->{make}->failed :
8953              $self->{make} =~ /^NO/
8954             ) and push @e, "Can't test without successful make";
8955         $self->{badtestcnt} ||= 0;
8956         if ($self->{badtestcnt} > 0) {
8957             require Data::Dumper;
8958             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8959             push @e, "Won't repeat unsuccessful test during this command";
8960         }
8961
8962         push @e, $self->{later} if $self->{later};
8963         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8964
8965         if (exists $self->{build_dir}) {
8966             if (exists $self->{make_test}) {
8967                 if (
8968                     UNIVERSAL::can($self->{make_test},"failed") ?
8969                     $self->{make_test}->failed :
8970                     $self->{make_test} =~ /^NO/
8971                    ) {
8972                     if (
8973                         UNIVERSAL::can($self->{make_test},"commandid")
8974                         &&
8975                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8976                        ) {
8977                         push @e, "Has already been tested within this command";
8978                     }
8979                 } else {
8980                     push @e, "Has already been tested successfully";
8981                     # if global "is_tested" has been cleared, we need to mark this to
8982                     # be added to PERL5LIB if not already installed
8983                     if ($self->tested_ok_but_not_installed) {
8984                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8985                     }
8986                 }
8987             }
8988         } elsif (!@e) {
8989             push @e, "Has no own directory";
8990         }
8991         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8992         unless (chdir $self->{build_dir}) {
8993             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8994         }
8995         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8996     }
8997     $self->debug("Changed directory to $self->{build_dir}")
8998         if $CPAN::DEBUG;
8999
9000     if ($^O eq 'MacOS') {
9001         Mac::BuildTools::make_test($self);
9002         return;
9003     }
9004
9005     if ($self->{modulebuild}) {
9006         my $thm = CPAN::Shell->expand("Module","Test::Harness");
9007         my $v = $thm->inst_version;
9008         if (CPAN::Version->vlt($v,2.62)) {
9009             # XXX Eric Wilhelm reported this as a bug: klapperl:
9010             # Test::Harness 3.0 self-tests, so that should be 'unless
9011             # installing Test::Harness'
9012             unless ($self->id eq $thm->distribution->id) {
9013                $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
9014   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
9015                 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
9016                 return;
9017             }
9018         }
9019     }
9020
9021     if ( ! $self->{force_update}  ) {
9022         # bypass actual tests if "trust_test_report_history" and have a report
9023         my $have_tested_fcn;
9024         if (   $CPAN::Config->{trust_test_report_history}
9025             && $CPAN::META->has_inst("CPAN::Reporter::History")
9026             && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
9027             if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
9028                 # Do nothing if grade was DISCARD
9029                 if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
9030                     $self->{make_test} = CPAN::Distrostatus->new("YES");
9031                     # if global "is_tested" has been cleared, we need to mark this to
9032                     # be added to PERL5LIB if not already installed
9033                     if ($self->tested_ok_but_not_installed) {
9034                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9035                     }
9036                     $CPAN::Frontend->myprint("Found prior test report -- OK\n");
9037                     return;
9038                 }
9039                 elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
9040                     $self->{make_test} = CPAN::Distrostatus->new("NO");
9041                     $self->{badtestcnt}++;
9042                     $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
9043                     return;
9044                 }
9045             }
9046         }
9047     }
9048
9049     my $system;
9050     my $prefs_test = $self->prefs->{test};
9051     if (my $commandline
9052         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
9053         $system = $commandline;
9054         $ENV{PERL} = CPAN::find_perl;
9055     } elsif ($self->{modulebuild}) {
9056         $system = sprintf "%s test", $self->_build_command();
9057         unless (-e "Build") {
9058             my $id = $self->pretty_id;
9059             $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
9060         }
9061     } else {
9062         $system = join " ", $self->_make_command(), "test";
9063     }
9064     my $make_test_arg = $self->_make_phase_arg("test");
9065     $system = sprintf("%s%s",
9066                       $system,
9067                       $make_test_arg ? " $make_test_arg" : "",
9068                      );
9069     my($tests_ok);
9070     my %env;
9071     while (my($k,$v) = each %ENV) {
9072         next unless defined $v;
9073         $env{$k} = $v;
9074     }
9075     local %ENV = %env;
9076     my $test_env;
9077     if ($self->prefs->{test}) {
9078         $test_env = $self->prefs->{test}{env};
9079     }
9080     if ($test_env) {
9081         for my $e (keys %$test_env) {
9082             $ENV{$e} = $test_env->{$e};
9083         }
9084     }
9085     my $expect_model = $self->_prefs_with_expect("test");
9086     my $want_expect = 0;
9087     if ( $expect_model && @{$expect_model->{talk}} ) {
9088         my $can_expect = $CPAN::META->has_inst("Expect");
9089         if ($can_expect) {
9090             $want_expect = 1;
9091         } else {
9092             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
9093                                     "testing without\n");
9094         }
9095     }
9096     if ($want_expect) {
9097         if ($self->_should_report('test')) {
9098             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
9099                                     "not supported when distroprefs specify ".
9100                                     "an interactive test\n");
9101         }
9102         $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
9103     } elsif ( $self->_should_report('test') ) {
9104         $tests_ok = CPAN::Reporter::test($self, $system);
9105     } else {
9106         $tests_ok = system($system) == 0;
9107     }
9108     $self->introduce_myself;
9109     if ( $tests_ok ) {
9110         {
9111             my @prereq;
9112
9113             # local $CPAN::DEBUG = 16; # Distribution
9114             for my $m (keys %{$self->{sponsored_mods}}) {
9115                 next unless $self->{sponsored_mods}{$m} > 0;
9116                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
9117                 # XXX we need available_version which reflects
9118                 # $ENV{PERL5LIB} so that already tested but not yet
9119                 # installed modules are counted.
9120                 my $available_version = $m_obj->available_version;
9121                 my $available_file = $m_obj->available_file;
9122                 if ($available_version &&
9123                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
9124                    ) {
9125                     CPAN->debug("m[$m] good enough available_version[$available_version]")
9126                         if $CPAN::DEBUG;
9127                 } elsif ($available_file
9128                          && (
9129                              !$self->{prereq_pm}{$m}
9130                              ||
9131                              $self->{prereq_pm}{$m} == 0
9132                             )
9133                         ) {
9134                     # lex Class::Accessor::Chained::Fast which has no $VERSION
9135                     CPAN->debug("m[$m] have available_file[$available_file]")
9136                         if $CPAN::DEBUG;
9137                 } else {
9138                     push @prereq, $m;
9139                 }
9140             }
9141             if (@prereq) {
9142                 my $cnt = @prereq;
9143                 my $which = join ",", @prereq;
9144                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
9145                     "$cnt dependencies missing ($which)";
9146                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
9147                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
9148                 $self->store_persistent_state;
9149                 return $self->goodbye("[dependencies] -- NA");
9150             }
9151         }
9152
9153         $CPAN::Frontend->myprint("  $system -- OK\n");
9154         $self->{make_test} = CPAN::Distrostatus->new("YES");
9155         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9156         # probably impossible to need the next line because badtestcnt
9157         # has a lifespan of one command
9158         delete $self->{badtestcnt};
9159     } else {
9160         $self->{make_test} = CPAN::Distrostatus->new("NO");
9161         $self->{badtestcnt}++;
9162         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
9163         CPAN::Shell->optprint
9164               ("hint",
9165                sprintf
9166                ("//hint// to see the cpan-testers results for installing this module, try:
9167   reports %s\n",
9168                 $self->pretty_id));
9169     }
9170     $self->store_persistent_state;
9171 }
9172
9173 sub _prefs_with_expect {
9174     my($self,$where) = @_;
9175     return unless my $prefs = $self->prefs;
9176     return unless my $where_prefs = $prefs->{$where};
9177     if ($where_prefs->{expect}) {
9178         return {
9179                 mode => "deterministic",
9180                 timeout => 15,
9181                 talk => $where_prefs->{expect},
9182                };
9183     } elsif ($where_prefs->{"eexpect"}) {
9184         return $where_prefs->{"eexpect"};
9185     }
9186     return;
9187 }
9188
9189 #-> sub CPAN::Distribution::clean ;
9190 sub clean {
9191     my($self) = @_;
9192     my $make = $self->{modulebuild} ? "Build" : "make";
9193     $CPAN::Frontend->myprint("Running $make clean\n");
9194     unless (exists $self->{archived}) {
9195         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
9196                                 "/untarred, nothing done\n");
9197         return 1;
9198     }
9199     unless (exists $self->{build_dir}) {
9200         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
9201         return 1;
9202     }
9203     if (exists $self->{writemakefile}
9204         and $self->{writemakefile}->failed
9205        ) {
9206         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
9207         return 1;
9208     }
9209   EXCUSE: {
9210         my @e;
9211         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
9212             push @e, "make clean already called once";
9213         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
9214     }
9215     chdir $self->{build_dir} or
9216         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
9217     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
9218
9219     if ($^O eq 'MacOS') {
9220         Mac::BuildTools::make_clean($self);
9221         return;
9222     }
9223
9224     my $system;
9225     if ($self->{modulebuild}) {
9226         unless (-f "Build") {
9227             my $cwd = CPAN::anycwd();
9228             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
9229                                     " in cwd[$cwd]. Danger, Will Robinson!");
9230             $CPAN::Frontend->mysleep(5);
9231         }
9232         $system = sprintf "%s clean", $self->_build_command();
9233     } else {
9234         $system  = join " ", $self->_make_command(), "clean";
9235     }
9236     my $system_ok = system($system) == 0;
9237     $self->introduce_myself;
9238     if ( $system_ok ) {
9239       $CPAN::Frontend->myprint("  $system -- OK\n");
9240
9241       # $self->force;
9242
9243       # Jost Krieger pointed out that this "force" was wrong because
9244       # it has the effect that the next "install" on this distribution
9245       # will untar everything again. Instead we should bring the
9246       # object's state back to where it is after untarring.
9247
9248       for my $k (qw(
9249                     force_update
9250                     install
9251                     writemakefile
9252                     make
9253                     make_test
9254                    )) {
9255           delete $self->{$k};
9256       }
9257       $self->{make_clean} = CPAN::Distrostatus->new("YES");
9258
9259     } else {
9260       # Hmmm, what to do if make clean failed?
9261
9262       $self->{make_clean} = CPAN::Distrostatus->new("NO");
9263       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
9264
9265       # 2006-02-27: seems silly to me to force a make now
9266       # $self->force("make"); # so that this directory won't be used again
9267
9268     }
9269     $self->store_persistent_state;
9270 }
9271
9272 #-> sub CPAN::Distribution::goto ;
9273 sub goto {
9274     my($self,$goto) = @_;
9275     $goto = $self->normalize($goto);
9276     my $why = sprintf(
9277                       "Goto '$goto' via prefs file '%s' doc %d",
9278                       $self->{prefs_file},
9279                       $self->{prefs_file_doc},
9280                      );
9281     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
9282     # 2007-07-16 akoenig : Better than NA would be if we could inherit
9283     # the status of the $goto distro but given the exceptional nature
9284     # of 'goto' I feel reluctant to implement it
9285     my $goodbye_message = "[goto] -- NA $why";
9286     $self->goodbye($goodbye_message);
9287
9288     # inject into the queue
9289
9290     CPAN::Queue->delete($self->id);
9291     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
9292
9293     # and run where we left off
9294
9295     my($method) = (caller(1))[3];
9296     CPAN->instance("CPAN::Distribution",$goto)->$method();
9297     CPAN::Queue->delete_first($goto);
9298 }
9299
9300 #-> sub CPAN::Distribution::install ;
9301 sub install {
9302     my($self) = @_;
9303     if (my $goto = $self->prefs->{goto}) {
9304         return $self->goto($goto);
9305     }
9306     # $DB::single=1;
9307     unless ($self->{badtestcnt}) {
9308         $self->test;
9309     }
9310     if ($CPAN::Signal) {
9311       delete $self->{force_update};
9312       return;
9313     }
9314     my $make = $self->{modulebuild} ? "Build" : "make";
9315     $CPAN::Frontend->myprint("Running $make install\n");
9316   EXCUSE: {
9317         my @e;
9318         if ($self->{make} or $self->{later}) {
9319             # go ahead
9320         } else {
9321             push @e,
9322                 "Make had some problems, won't install";
9323         }
9324
9325         exists $self->{make} and
9326             (
9327              UNIVERSAL::can($self->{make},"failed") ?
9328              $self->{make}->failed :
9329              $self->{make} =~ /^NO/
9330             ) and
9331             push @e, "Make had returned bad status, install seems impossible";
9332
9333         if (exists $self->{build_dir}) {
9334         } elsif (!@e) {
9335             push @e, "Has no own directory";
9336         }
9337
9338         if (exists $self->{make_test} and
9339             (
9340              UNIVERSAL::can($self->{make_test},"failed") ?
9341              $self->{make_test}->failed :
9342              $self->{make_test} =~ /^NO/
9343             )) {
9344             if ($self->{force_update}) {
9345                 $self->{make_test}->text("FAILED but failure ignored because ".
9346                                          "'force' in effect");
9347             } else {
9348                 push @e, "make test had returned bad status, ".
9349                     "won't install without force"
9350             }
9351         }
9352         if (exists $self->{install}) {
9353             if (UNIVERSAL::can($self->{install},"text") ?
9354                 $self->{install}->text eq "YES" :
9355                 $self->{install} =~ /^YES/
9356                ) {
9357                 $CPAN::Frontend->myprint("  Already done\n");
9358                 $CPAN::META->is_installed($self->{build_dir});
9359                 return 1;
9360             } else {
9361                 # comment in Todo on 2006-02-11; maybe retry?
9362                 push @e, "Already tried without success";
9363             }
9364         }
9365
9366         push @e, $self->{later} if $self->{later};
9367         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
9368
9369         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
9370         unless (chdir $self->{build_dir}) {
9371             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
9372         }
9373         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
9374     }
9375     $self->debug("Changed directory to $self->{build_dir}")
9376         if $CPAN::DEBUG;
9377
9378     if ($^O eq 'MacOS') {
9379         Mac::BuildTools::make_install($self);
9380         return;
9381     }
9382
9383     my $system;
9384     if (my $commandline = $self->prefs->{install}{commandline}) {
9385         $system = $commandline;
9386         $ENV{PERL} = CPAN::find_perl;
9387     } elsif ($self->{modulebuild}) {
9388         my($mbuild_install_build_command) =
9389             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
9390                 $CPAN::Config->{mbuild_install_build_command} ?
9391                     $CPAN::Config->{mbuild_install_build_command} :
9392                         $self->_build_command();
9393         $system = sprintf("%s install %s",
9394                           $mbuild_install_build_command,
9395                           $CPAN::Config->{mbuild_install_arg},
9396                          );
9397     } else {
9398         my($make_install_make_command) =
9399             CPAN::HandleConfig->prefs_lookup($self,
9400                                              q{make_install_make_command})
9401                   || $self->_make_command();
9402         $system = sprintf("%s install %s",
9403                           $make_install_make_command,
9404                           $CPAN::Config->{make_install_arg},
9405                          );
9406     }
9407
9408     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
9409     my $brip = CPAN::HandleConfig->prefs_lookup($self,
9410                                                 q{build_requires_install_policy});
9411     $brip ||="ask/yes";
9412     my $id = $self->id;
9413     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
9414     my $want_install = "yes";
9415     if ($reqtype eq "b") {
9416         if ($brip eq "no") {
9417             $want_install = "no";
9418         } elsif ($brip =~ m|^ask/(.+)|) {
9419             my $default = $1;
9420             $default = "yes" unless $default =~ /^(y|n)/i;
9421             $want_install =
9422                 CPAN::Shell::colorable_makemaker_prompt
9423                       ("$id is just needed temporarily during building or testing. ".
9424                        "Do you want to install it permanently? (Y/n)",
9425                        $default);
9426         }
9427     }
9428     unless ($want_install =~ /^y/i) {
9429         my $is_only = "is only 'build_requires'";
9430         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
9431         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
9432         delete $self->{force_update};
9433         return;
9434     }
9435     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
9436                            ? $ENV{PERL5LIB}
9437                            : ($ENV{PERLLIB} || "");
9438
9439     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
9440     $CPAN::META->set_perl5lib;
9441     my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
9442 ("Can't execute $system: $!");
9443     my($makeout) = "";
9444     while (<$pipe>) {
9445         print $_; # intentionally NOT use Frontend->myprint because it
9446                   # looks irritating when we markup in color what we
9447                   # just pass through from an external program
9448         $makeout .= $_;
9449     }
9450     $pipe->close;
9451     my $close_ok = $? == 0;
9452     $self->introduce_myself;
9453     if ( $close_ok ) {
9454         $CPAN::Frontend->myprint("  $system -- OK\n");
9455         $CPAN::META->is_installed($self->{build_dir});
9456         $self->{install} = CPAN::Distrostatus->new("YES");
9457     } else {
9458         $self->{install} = CPAN::Distrostatus->new("NO");
9459         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
9460         my $mimc =
9461             CPAN::HandleConfig->prefs_lookup($self,
9462                                              q{make_install_make_command});
9463         if (
9464             $makeout =~ /permission/s
9465             && $> > 0
9466             && (
9467                 ! $mimc
9468                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9469                                                               q{make}))
9470                )
9471            ) {
9472             $CPAN::Frontend->myprint(
9473                                      qq{----\n}.
9474                                      qq{  You may have to su }.
9475                                      qq{to root to install the package\n}.
9476                                      qq{  (Or you may want to run something like\n}.
9477                                      qq{    o conf make_install_make_command 'sudo make'\n}.
9478                                      qq{  to raise your permissions.}
9479                                     );
9480         }
9481     }
9482     delete $self->{force_update};
9483     # $DB::single = 1;
9484     $self->store_persistent_state;
9485 }
9486
9487 sub introduce_myself {
9488     my($self) = @_;
9489     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
9490 }
9491
9492 #-> sub CPAN::Distribution::dir ;
9493 sub dir {
9494     shift->{build_dir};
9495 }
9496
9497 #-> sub CPAN::Distribution::perldoc ;
9498 sub perldoc {
9499     my($self) = @_;
9500
9501     my($dist) = $self->id;
9502     my $package = $self->called_for;
9503
9504     $self->_display_url( $CPAN::Defaultdocs . $package );
9505 }
9506
9507 #-> sub CPAN::Distribution::_check_binary ;
9508 sub _check_binary {
9509     my ($dist,$shell,$binary) = @_;
9510     my ($pid,$out);
9511
9512     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9513       if $CPAN::DEBUG;
9514
9515     if ($CPAN::META->has_inst("File::Which")) {
9516         return File::Which::which($binary);
9517     } else {
9518         local *README;
9519         $pid = open README, "which $binary|"
9520             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9521         return unless $pid;
9522         while (<README>) {
9523             $out .= $_;
9524         }
9525         close README
9526             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9527                 and return;
9528     }
9529
9530     $CPAN::Frontend->myprint(qq{   + $out \n})
9531       if $CPAN::DEBUG && $out;
9532
9533     return $out;
9534 }
9535
9536 #-> sub CPAN::Distribution::_display_url ;
9537 sub _display_url {
9538     my($self,$url) = @_;
9539     my($res,$saved_file,$pid,$out);
9540
9541     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9542       if $CPAN::DEBUG;
9543
9544     # should we define it in the config instead?
9545     my $html_converter = "html2text.pl";
9546
9547     my $web_browser = $CPAN::Config->{'lynx'} || undef;
9548     my $web_browser_out = $web_browser
9549         ? CPAN::Distribution->_check_binary($self,$web_browser)
9550         : undef;
9551
9552     if ($web_browser_out) {
9553         # web browser found, run the action
9554         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9555         $CPAN::Frontend->myprint(qq{system[$browser $url]})
9556             if $CPAN::DEBUG;
9557         $CPAN::Frontend->myprint(qq{
9558 Displaying URL
9559   $url
9560 with browser $browser
9561 });
9562         $CPAN::Frontend->mysleep(1);
9563         system("$browser $url");
9564         if ($saved_file) { 1 while unlink($saved_file) }
9565     } else {
9566         # web browser not found, let's try text only
9567         my $html_converter_out =
9568             CPAN::Distribution->_check_binary($self,$html_converter);
9569         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9570
9571         if ($html_converter_out ) {
9572             # html2text found, run it
9573             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9574             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9575                 unless defined($saved_file);
9576
9577             local *README;
9578             $pid = open README, "$html_converter $saved_file |"
9579                 or $CPAN::Frontend->mydie(qq{
9580 Could not fork '$html_converter $saved_file': $!});
9581             my($fh,$filename);
9582             if ($CPAN::META->has_usable("File::Temp")) {
9583                 $fh = File::Temp->new(
9584                                       dir      => File::Spec->tmpdir,
9585                                       template => 'cpan_htmlconvert_XXXX',
9586                                       suffix => '.txt',
9587                                       unlink => 0,
9588                                      );
9589                 $filename = $fh->filename;
9590             } else {
9591                 $filename = "cpan_htmlconvert_$$.txt";
9592                 $fh = FileHandle->new();
9593                 open $fh, ">$filename" or die;
9594             }
9595             while (<README>) {
9596                 $fh->print($_);
9597             }
9598             close README or
9599                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9600             my $tmpin = $fh->filename;
9601             $CPAN::Frontend->myprint(sprintf(qq{
9602 Run '%s %s' and
9603 saved output to %s\n},
9604                                              $html_converter,
9605                                              $saved_file,
9606                                              $tmpin,
9607                                             )) if $CPAN::DEBUG;
9608             close $fh;
9609             local *FH;
9610             open FH, $tmpin
9611                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9612             my $fh_pager = FileHandle->new;
9613             local($SIG{PIPE}) = "IGNORE";
9614             my $pager = $CPAN::Config->{'pager'} || "cat";
9615             $fh_pager->open("|$pager")
9616                 or $CPAN::Frontend->mydie(qq{
9617 Could not open pager '$pager': $!});
9618             $CPAN::Frontend->myprint(qq{
9619 Displaying URL
9620   $url
9621 with pager "$pager"
9622 });
9623             $CPAN::Frontend->mysleep(1);
9624             $fh_pager->print(<FH>);
9625             $fh_pager->close;
9626         } else {
9627             # coldn't find the web browser or html converter
9628             $CPAN::Frontend->myprint(qq{
9629 You need to install lynx or $html_converter to use this feature.});
9630         }
9631     }
9632 }
9633
9634 #-> sub CPAN::Distribution::_getsave_url ;
9635 sub _getsave_url {
9636     my($dist, $shell, $url) = @_;
9637
9638     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9639       if $CPAN::DEBUG;
9640
9641     my($fh,$filename);
9642     if ($CPAN::META->has_usable("File::Temp")) {
9643         $fh = File::Temp->new(
9644                               dir      => File::Spec->tmpdir,
9645                               template => "cpan_getsave_url_XXXX",
9646                               suffix => ".html",
9647                               unlink => 0,
9648                              );
9649         $filename = $fh->filename;
9650     } else {
9651         $fh = FileHandle->new;
9652         $filename = "cpan_getsave_url_$$.html";
9653     }
9654     my $tmpin = $filename;
9655     if ($CPAN::META->has_usable('LWP')) {
9656         $CPAN::Frontend->myprint("Fetching with LWP:
9657   $url
9658 ");
9659         my $Ua;
9660         CPAN::LWP::UserAgent->config;
9661         eval { $Ua = CPAN::LWP::UserAgent->new; };
9662         if ($@) {
9663             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9664             return;
9665         } else {
9666             my($var);
9667             $Ua->proxy('http', $var)
9668                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9669             $Ua->no_proxy($var)
9670                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9671         }
9672
9673         my $req = HTTP::Request->new(GET => $url);
9674         $req->header('Accept' => 'text/html');
9675         my $res = $Ua->request($req);
9676         if ($res->is_success) {
9677             $CPAN::Frontend->myprint(" + request successful.\n")
9678                 if $CPAN::DEBUG;
9679             print $fh $res->content;
9680             close $fh;
9681             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9682                 if $CPAN::DEBUG;
9683             return $tmpin;
9684         } else {
9685             $CPAN::Frontend->myprint(sprintf(
9686                                              "LWP failed with code[%s], message[%s]\n",
9687                                              $res->code,
9688                                              $res->message,
9689                                             ));
9690             return;
9691         }
9692     } else {
9693         $CPAN::Frontend->mywarn("  LWP not available\n");
9694         return;
9695     }
9696 }
9697
9698 #-> sub CPAN::Distribution::_build_command
9699 sub _build_command {
9700     my($self) = @_;
9701     if ($^O eq "MSWin32") { # special code needed at least up to
9702                             # Module::Build 0.2611 and 0.2706; a fix
9703                             # in M:B has been promised 2006-01-30
9704         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9705         return "$perl ./Build";
9706     }
9707     return "./Build";
9708 }
9709
9710 #-> sub CPAN::Distribution::_should_report
9711 sub _should_report {
9712     my($self, $phase) = @_;
9713     die "_should_report() requires a 'phase' argument"
9714         if ! defined $phase;
9715
9716     # configured
9717     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9718                                                        q{test_report});
9719     return unless $test_report;
9720
9721     # don't repeat if we cached a result
9722     return $self->{should_report}
9723         if exists $self->{should_report};
9724
9725     # don't report if we generated a Makefile.PL
9726     if ( $self->{had_no_makefile_pl} ) {
9727         $CPAN::Frontend->mywarn(
9728             "Will not send CPAN Testers report with generated Makefile.PL.\n"
9729         );
9730         return $self->{should_report} = 0;
9731     }
9732
9733     # available
9734     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9735         $CPAN::Frontend->mywarn(
9736             "CPAN::Reporter not installed.  No reports will be sent.\n"
9737         );
9738         return $self->{should_report} = 0;
9739     }
9740
9741     # capable
9742     my $crv = CPAN::Reporter->VERSION;
9743     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9744         # don't cache $self->{should_report} -- need to check each phase
9745         if ( $phase eq 'test' ) {
9746             return 1;
9747         }
9748         else {
9749             $CPAN::Frontend->mywarn(
9750                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9751                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9752             );
9753             return;
9754         }
9755     }
9756
9757     # appropriate
9758     if ($self->is_dot_dist) {
9759         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9760                                 "for local directories\n");
9761         return $self->{should_report} = 0;
9762     }
9763     if ($self->prefs->{patches}
9764         &&
9765         @{$self->prefs->{patches}}
9766         &&
9767         $self->{patched}
9768        ) {
9769         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9770                                 "when the source has been patched\n");
9771         return $self->{should_report} = 0;
9772     }
9773
9774     # proceed and cache success
9775     return $self->{should_report} = 1;
9776 }
9777
9778 #-> sub CPAN::Distribution::reports
9779 sub reports {
9780     my($self) = @_;
9781     my $pathname = $self->id;
9782     $CPAN::Frontend->myprint("Distribution: $pathname\n");
9783
9784     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9785         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9786     }
9787     unless ($CPAN::META->has_usable("LWP")) {
9788         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9789     }
9790     unless ($CPAN::META->has_usable("File::Temp")) {
9791         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9792     }
9793
9794     my $d = CPAN::DistnameInfo->new($pathname);
9795
9796     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9797     my $version   = $d->version;   # "0.02"
9798     my $maturity  = $d->maturity;  # "released"
9799     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9800     my $cpanid    = $d->cpanid;    # "GBARR"
9801     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9802
9803     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9804
9805     CPAN::LWP::UserAgent->config;
9806     my $Ua;
9807     eval { $Ua = CPAN::LWP::UserAgent->new; };
9808     if ($@) {
9809         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9810     }
9811     $CPAN::Frontend->myprint("Fetching '$url'...");
9812     my $resp = $Ua->get($url);
9813     unless ($resp->is_success) {
9814         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9815     }
9816     $CPAN::Frontend->myprint("DONE\n\n");
9817     my $yaml = $resp->content;
9818     # was fuer ein Umweg!
9819     my $fh = File::Temp->new(
9820                              dir      => File::Spec->tmpdir,
9821                              template => 'cpan_reports_XXXX',
9822                              suffix => '.yaml',
9823                              unlink => 0,
9824                             );
9825     my $tfilename = $fh->filename;
9826     print $fh $yaml;
9827     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9828     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9829     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9830     my %other_versions;
9831     my $this_version_seen;
9832     for my $rep (@$unserialized) {
9833         my $rversion = $rep->{version};
9834         if ($rversion eq $version) {
9835             unless ($this_version_seen++) {
9836                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9837             }
9838             $CPAN::Frontend->myprint
9839                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9840                          $rep->{archname} eq $Config::Config{archname}?"*":"",
9841                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9842                          $rep->{action},
9843                          $rep->{perl},
9844                          ucfirst $rep->{osname},
9845                          $rep->{osvers},
9846                          $rep->{archname},
9847                         ));
9848         } else {
9849             $other_versions{$rep->{version}}++;
9850         }
9851     }
9852     unless ($this_version_seen) {
9853         $CPAN::Frontend->myprint("No reports found for version '$version'
9854 Reports for other versions:\n");
9855         for my $v (sort keys %other_versions) {
9856             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9857         }
9858     }
9859     $url =~ s/\.yaml/.html/;
9860     $CPAN::Frontend->myprint("See $url for details\n");
9861 }
9862
9863 package CPAN::Bundle;
9864 use strict;
9865
9866 sub look {
9867     my $self = shift;
9868     $CPAN::Frontend->myprint($self->as_string);
9869 }
9870
9871 #-> CPAN::Bundle::undelay
9872 sub undelay {
9873     my $self = shift;
9874     delete $self->{later};
9875     for my $c ( $self->contains ) {
9876         my $obj = CPAN::Shell->expandany($c) or next;
9877         $obj->undelay;
9878     }
9879 }
9880
9881 # mark as dirty/clean
9882 #-> sub CPAN::Bundle::color_cmd_tmps ;
9883 sub color_cmd_tmps {
9884     my($self) = shift;
9885     my($depth) = shift || 0;
9886     my($color) = shift || 0;
9887     my($ancestors) = shift || [];
9888     # a module needs to recurse to its cpan_file, a distribution needs
9889     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9890
9891     return if exists $self->{incommandcolor}
9892         && $color==1
9893         && $self->{incommandcolor}==$color;
9894     if ($depth>=$CPAN::MAX_RECURSION) {
9895         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9896     }
9897     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9898
9899     for my $c ( $self->contains ) {
9900         my $obj = CPAN::Shell->expandany($c) or next;
9901         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9902         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9903     }
9904     # never reached code?
9905     #if ($color==0) {
9906       #delete $self->{badtestcnt};
9907     #}
9908     $self->{incommandcolor} = $color;
9909 }
9910
9911 #-> sub CPAN::Bundle::as_string ;
9912 sub as_string {
9913     my($self) = @_;
9914     $self->contains;
9915     # following line must be "=", not "||=" because we have a moving target
9916     $self->{INST_VERSION} = $self->inst_version;
9917     return $self->SUPER::as_string;
9918 }
9919
9920 #-> sub CPAN::Bundle::contains ;
9921 sub contains {
9922     my($self) = @_;
9923     my($inst_file) = $self->inst_file || "";
9924     my($id) = $self->id;
9925     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9926     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9927         undef $inst_file;
9928     }
9929     unless ($inst_file) {
9930         # Try to get at it in the cpan directory
9931         $self->debug("no inst_file") if $CPAN::DEBUG;
9932         my $cpan_file;
9933         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9934               $cpan_file = $self->cpan_file;
9935         if ($cpan_file eq "N/A") {
9936             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9937   Maybe stale symlink? Maybe removed during session? Giving up.\n");
9938         }
9939         my $dist = $CPAN::META->instance('CPAN::Distribution',
9940                                          $self->cpan_file);
9941         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9942         $dist->get;
9943         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9944         my($todir) = $CPAN::Config->{'cpan_home'};
9945         my(@me,$from,$to,$me);
9946         @me = split /::/, $self->id;
9947         $me[-1] .= ".pm";
9948         $me = File::Spec->catfile(@me);
9949         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9950         $to = File::Spec->catfile($todir,$me);
9951         File::Path::mkpath(File::Basename::dirname($to));
9952         File::Copy::copy($from, $to)
9953               or Carp::confess("Couldn't copy $from to $to: $!");
9954         $inst_file = $to;
9955     }
9956     my @result;
9957     my $fh = FileHandle->new;
9958     local $/ = "\n";
9959     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9960     my $in_cont = 0;
9961     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9962     while (<$fh>) {
9963         $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
9964             m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
9965         next unless $in_cont;
9966         next if /^=/;
9967         s/\#.*//;
9968         next if /^\s+$/;
9969         chomp;
9970         push @result, (split " ", $_, 2)[0];
9971     }
9972     close $fh;
9973     delete $self->{STATUS};
9974     $self->{CONTAINS} = \@result;
9975     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9976     unless (@result) {
9977         $CPAN::Frontend->mywarn(qq{
9978 The bundle file "$inst_file" may be a broken
9979 bundlefile. It seems not to contain any bundle definition.
9980 Please check the file and if it is bogus, please delete it.
9981 Sorry for the inconvenience.
9982 });
9983     }
9984     @result;
9985 }
9986
9987 #-> sub CPAN::Bundle::find_bundle_file
9988 # $where is in local format, $what is in unix format
9989 sub find_bundle_file {
9990     my($self,$where,$what) = @_;
9991     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9992 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9993 ###    my $bu = File::Spec->catfile($where,$what);
9994 ###    return $bu if -f $bu;
9995     my $manifest = File::Spec->catfile($where,"MANIFEST");
9996     unless (-f $manifest) {
9997         require ExtUtils::Manifest;
9998         my $cwd = CPAN::anycwd();
9999         $self->safe_chdir($where);
10000         ExtUtils::Manifest::mkmanifest();
10001         $self->safe_chdir($cwd);
10002     }
10003     my $fh = FileHandle->new($manifest)
10004         or Carp::croak("Couldn't open $manifest: $!");
10005     local($/) = "\n";
10006     my $bundle_filename = $what;
10007     $bundle_filename =~ s|Bundle.*/||;
10008     my $bundle_unixpath;
10009     while (<$fh>) {
10010         next if /^\s*\#/;
10011         my($file) = /(\S+)/;
10012         if ($file =~ m|\Q$what\E$|) {
10013             $bundle_unixpath = $file;
10014             # return File::Spec->catfile($where,$bundle_unixpath); # bad
10015             last;
10016         }
10017         # retry if she managed to have no Bundle directory
10018         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
10019     }
10020     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
10021         if $bundle_unixpath;
10022     Carp::croak("Couldn't find a Bundle file in $where");
10023 }
10024
10025 # needs to work quite differently from Module::inst_file because of
10026 # cpan_home/Bundle/ directory and the possibility that we have
10027 # shadowing effect. As it makes no sense to take the first in @INC for
10028 # Bundles, we parse them all for $VERSION and take the newest.
10029
10030 #-> sub CPAN::Bundle::inst_file ;
10031 sub inst_file {
10032     my($self) = @_;
10033     my($inst_file);
10034     my(@me);
10035     @me = split /::/, $self->id;
10036     $me[-1] .= ".pm";
10037     my($incdir,$bestv);
10038     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
10039         my $parsefile = File::Spec->catfile($incdir, @me);
10040         CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
10041         next unless -f $parsefile;
10042         my $have = eval { MM->parse_version($parsefile); };
10043         if ($@) {
10044             $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10045         }
10046         if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
10047             $self->{INST_FILE} = $parsefile;
10048             $self->{INST_VERSION} = $bestv = $have;
10049         }
10050     }
10051     $self->{INST_FILE};
10052 }
10053
10054 #-> sub CPAN::Bundle::inst_version ;
10055 sub inst_version {
10056     my($self) = @_;
10057     $self->inst_file; # finds INST_VERSION as side effect
10058     $self->{INST_VERSION};
10059 }
10060
10061 #-> sub CPAN::Bundle::rematein ;
10062 sub rematein {
10063     my($self,$meth) = @_;
10064     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
10065     my($id) = $self->id;
10066     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
10067         unless $self->inst_file || $self->cpan_file;
10068     my($s,%fail);
10069     for $s ($self->contains) {
10070         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
10071             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
10072         if ($type eq 'CPAN::Distribution') {
10073             $CPAN::Frontend->mywarn(qq{
10074 The Bundle }.$self->id.qq{ contains
10075 explicitly a file '$s'.
10076 Going to $meth that.
10077 });
10078             $CPAN::Frontend->mysleep(5);
10079         }
10080         # possibly noisy action:
10081         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
10082         my $obj = $CPAN::META->instance($type,$s);
10083         $obj->{reqtype} = $self->{reqtype};
10084         $obj->$meth();
10085     }
10086 }
10087
10088 # If a bundle contains another that contains an xs_file we have here,
10089 # we just don't bother I suppose
10090 #-> sub CPAN::Bundle::xs_file
10091 sub xs_file {
10092     return 0;
10093 }
10094
10095 #-> sub CPAN::Bundle::force ;
10096 sub fforce   { shift->rematein('fforce',@_); }
10097 #-> sub CPAN::Bundle::force ;
10098 sub force   { shift->rematein('force',@_); }
10099 #-> sub CPAN::Bundle::notest ;
10100 sub notest  { shift->rematein('notest',@_); }
10101 #-> sub CPAN::Bundle::get ;
10102 sub get     { shift->rematein('get',@_); }
10103 #-> sub CPAN::Bundle::make ;
10104 sub make    { shift->rematein('make',@_); }
10105 #-> sub CPAN::Bundle::test ;
10106 sub test    {
10107     my $self = shift;
10108     # $self->{badtestcnt} ||= 0;
10109     $self->rematein('test',@_);
10110 }
10111 #-> sub CPAN::Bundle::install ;
10112 sub install {
10113   my $self = shift;
10114   $self->rematein('install',@_);
10115 }
10116 #-> sub CPAN::Bundle::clean ;
10117 sub clean   { shift->rematein('clean',@_); }
10118
10119 #-> sub CPAN::Bundle::uptodate ;
10120 sub uptodate {
10121     my($self) = @_;
10122     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
10123     my $c;
10124     foreach $c ($self->contains) {
10125         my $obj = CPAN::Shell->expandany($c);
10126         return 0 unless $obj->uptodate;
10127     }
10128     return 1;
10129 }
10130
10131 #-> sub CPAN::Bundle::readme ;
10132 sub readme  {
10133     my($self) = @_;
10134     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
10135 No File found for bundle } . $self->id . qq{\n}), return;
10136     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
10137     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
10138 }
10139
10140 package CPAN::Module;
10141 use strict;
10142
10143 # Accessors
10144 #-> sub CPAN::Module::userid
10145 sub userid {
10146     my $self = shift;
10147     my $ro = $self->ro;
10148     return unless $ro;
10149     return $ro->{userid} || $ro->{CPAN_USERID};
10150 }
10151 #-> sub CPAN::Module::description
10152 sub description {
10153     my $self = shift;
10154     my $ro = $self->ro or return "";
10155     $ro->{description}
10156 }
10157
10158 #-> sub CPAN::Module::distribution
10159 sub distribution {
10160     my($self) = @_;
10161     CPAN::Shell->expand("Distribution",$self->cpan_file);
10162 }
10163
10164 #-> sub CPAN::Module::_is_representative_module
10165 sub _is_representative_module {
10166     my($self) = @_;
10167     return $self->{_is_representative_module} if defined $self->{_is_representative_module};
10168     my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
10169     $pm =~ s|.+/||;
10170     $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
10171     $pm =~ s|-\d+\.\d+.+$||;
10172     $pm =~ s|-[\d\.]+$||;
10173     $pm =~ s/-/::/g;
10174     $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
10175     # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
10176     $self->{_is_representative_module};
10177 }
10178
10179 #-> sub CPAN::Module::undelay
10180 sub undelay {
10181     my $self = shift;
10182     delete $self->{later};
10183     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
10184         $dist->undelay;
10185     }
10186 }
10187
10188 # mark as dirty/clean
10189 #-> sub CPAN::Module::color_cmd_tmps ;
10190 sub color_cmd_tmps {
10191     my($self) = shift;
10192     my($depth) = shift || 0;
10193     my($color) = shift || 0;
10194     my($ancestors) = shift || [];
10195     # a module needs to recurse to its cpan_file
10196
10197     return if exists $self->{incommandcolor}
10198         && $color==1
10199         && $self->{incommandcolor}==$color;
10200     return if $color==0 && !$self->{incommandcolor};
10201     if ($color>=1) {
10202         if ( $self->uptodate ) {
10203             $self->{incommandcolor} = $color;
10204             return;
10205         } elsif (my $have_version = $self->available_version) {
10206             # maybe what we have is good enough
10207             if (@$ancestors) {
10208                 my $who_asked_for_me = $ancestors->[-1];
10209                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
10210                 if (0) {
10211                 } elsif ($obj->isa("CPAN::Bundle")) {
10212                     # bundles cannot specify a minimum version
10213                     return;
10214                 } elsif ($obj->isa("CPAN::Distribution")) {
10215                     if (my $prereq_pm = $obj->prereq_pm) {
10216                         for my $k (keys %$prereq_pm) {
10217                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
10218                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
10219                                     $self->{incommandcolor} = $color;
10220                                     return;
10221                                 }
10222                             }
10223                         }
10224                     }
10225                 }
10226             }
10227         }
10228     } else {
10229         $self->{incommandcolor} = $color; # set me before recursion,
10230                                           # so we can break it
10231     }
10232     if ($depth>=$CPAN::MAX_RECURSION) {
10233         die(CPAN::Exception::RecursiveDependency->new($ancestors));
10234     }
10235     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
10236
10237     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
10238         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
10239     }
10240     # unreached code?
10241     # if ($color==0) {
10242     #    delete $self->{badtestcnt};
10243     # }
10244     $self->{incommandcolor} = $color;
10245 }
10246
10247 #-> sub CPAN::Module::as_glimpse ;
10248 sub as_glimpse {
10249     my($self) = @_;
10250     my(@m);
10251     my $class = ref($self);
10252     $class =~ s/^CPAN:://;
10253     my $color_on = "";
10254     my $color_off = "";
10255     if (
10256         $CPAN::Shell::COLOR_REGISTERED
10257         &&
10258         $CPAN::META->has_inst("Term::ANSIColor")
10259         &&
10260         $self->description
10261        ) {
10262         $color_on = Term::ANSIColor::color("green");
10263         $color_off = Term::ANSIColor::color("reset");
10264     }
10265     my $uptodateness = " ";
10266     unless ($class eq "Bundle") {
10267         my $u = $self->uptodate;
10268         $uptodateness = $u ? "=" : "<" if defined $u;
10269     };
10270     my $id = do {
10271         my $d = $self->distribution;
10272         $d ? $d -> pretty_id : $self->cpan_userid;
10273     };
10274     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
10275                      $class,
10276                      $uptodateness,
10277                      $color_on,
10278                      $self->id,
10279                      $color_off,
10280                      $id,
10281                     );
10282     join "", @m;
10283 }
10284
10285 #-> sub CPAN::Module::dslip_status
10286 sub dslip_status {
10287     my($self) = @_;
10288     my($stat);
10289     # development status
10290     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
10291                                               pre-alpha alpha beta released
10292                                               mature standard,;
10293     # support level
10294     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
10295                                               developer comp.lang.perl.*
10296                                               none abandoned,;
10297     # language
10298     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
10299     # interface
10300     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
10301                                               references+ties
10302                                               object-oriented pragma
10303                                               hybrid none,;
10304     # public licence
10305     @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
10306                                               GPL LGPL
10307                                               BSD Artistic Artistic_2
10308                                               open-source
10309                                               distribution_allowed
10310                                               restricted_distribution
10311                                               no_licence,;
10312     for my $x (qw(d s l i p)) {
10313         $stat->{$x}{' '} = 'unknown';
10314         $stat->{$x}{'?'} = 'unknown';
10315     }
10316     my $ro = $self->ro;
10317     return +{} unless $ro && $ro->{statd};
10318     return {
10319             D  => $ro->{statd},
10320             S  => $ro->{stats},
10321             L  => $ro->{statl},
10322             I  => $ro->{stati},
10323             P  => $ro->{statp},
10324             DV => $stat->{D}{$ro->{statd}},
10325             SV => $stat->{S}{$ro->{stats}},
10326             LV => $stat->{L}{$ro->{statl}},
10327             IV => $stat->{I}{$ro->{stati}},
10328             PV => $stat->{P}{$ro->{statp}},
10329            };
10330 }
10331
10332 #-> sub CPAN::Module::as_string ;
10333 sub as_string {
10334     my($self) = @_;
10335     my(@m);
10336     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
10337     my $class = ref($self);
10338     $class =~ s/^CPAN:://;
10339     local($^W) = 0;
10340     push @m, $class, " id = $self->{ID}\n";
10341     my $sprintf = "    %-12s %s\n";
10342     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
10343         if $self->description;
10344     my $sprintf2 = "    %-12s %s (%s)\n";
10345     my($userid);
10346     $userid = $self->userid;
10347     if ( $userid ) {
10348         my $author;
10349         if ($author = CPAN::Shell->expand('Author',$userid)) {
10350             my $email = "";
10351             my $m; # old perls
10352             if ($m = $author->email) {
10353                 $email = " <$m>";
10354             }
10355             push @m, sprintf(
10356                              $sprintf2,
10357                              'CPAN_USERID',
10358                              $userid,
10359                              $author->fullname . $email
10360                             );
10361         }
10362     }
10363     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
10364         if $self->cpan_version;
10365     if (my $cpan_file = $self->cpan_file) {
10366         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
10367         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
10368             my $upload_date = $dist->upload_date;
10369             if ($upload_date) {
10370                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
10371             }
10372         }
10373     }
10374     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
10375     my $dslip = $self->dslip_status;
10376     push @m, sprintf(
10377                      $sprintf3,
10378                      'DSLIP_STATUS',
10379                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
10380                     ) if $dslip->{D};
10381     my $local_file = $self->inst_file;
10382     unless ($self->{MANPAGE}) {
10383         my $manpage;
10384         if ($local_file) {
10385             $manpage = $self->manpage_headline($local_file);
10386         } else {
10387             # If we have already untarred it, we should look there
10388             my $dist = $CPAN::META->instance('CPAN::Distribution',
10389                                              $self->cpan_file);
10390             # warn "dist[$dist]";
10391             # mff=manifest file; mfh=manifest handle
10392             my($mff,$mfh);
10393             if (
10394                 $dist->{build_dir}
10395                 and
10396                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
10397                 and
10398                 $mfh = FileHandle->new($mff)
10399                ) {
10400                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
10401                 my $lfre = $self->id; # local file RE
10402                 $lfre =~ s/::/./g;
10403                 $lfre .= "\\.pm\$";
10404                 my($lfl); # local file file
10405                 local $/ = "\n";
10406                 my(@mflines) = <$mfh>;
10407                 for (@mflines) {
10408                     s/^\s+//;
10409                     s/\s.*//s;
10410                 }
10411                 while (length($lfre)>5 and !$lfl) {
10412                     ($lfl) = grep /$lfre/, @mflines;
10413                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
10414                     $lfre =~ s/.+?\.//;
10415                 }
10416                 $lfl =~ s/\s.*//; # remove comments
10417                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
10418                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
10419                 # warn "lfl_abs[$lfl_abs]";
10420                 if (-f $lfl_abs) {
10421                     $manpage = $self->manpage_headline($lfl_abs);
10422                 }
10423             }
10424         }
10425         $self->{MANPAGE} = $manpage if $manpage;
10426     }
10427     my($item);
10428     for $item (qw/MANPAGE/) {
10429         push @m, sprintf($sprintf, $item, $self->{$item})
10430             if exists $self->{$item};
10431     }
10432     for $item (qw/CONTAINS/) {
10433         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
10434             if exists $self->{$item} && @{$self->{$item}};
10435     }
10436     push @m, sprintf($sprintf, 'INST_FILE',
10437                      $local_file || "(not installed)");
10438     push @m, sprintf($sprintf, 'INST_VERSION',
10439                      $self->inst_version) if $local_file;
10440     if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
10441         my $available_file = $self->available_file;
10442         if ($available_file && $available_file ne $local_file) {
10443             push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
10444             push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
10445         }
10446     }
10447     join "", @m, "\n";
10448 }
10449
10450 #-> sub CPAN::Module::manpage_headline
10451 sub manpage_headline {
10452     my($self,$local_file) = @_;
10453     my(@local_file) = $local_file;
10454     $local_file =~ s/\.pm(?!\n)\Z/.pod/;
10455     push @local_file, $local_file;
10456     my(@result,$locf);
10457     for $locf (@local_file) {
10458         next unless -f $locf;
10459         my $fh = FileHandle->new($locf)
10460             or $Carp::Frontend->mydie("Couldn't open $locf: $!");
10461         my $inpod = 0;
10462         local $/ = "\n";
10463         while (<$fh>) {
10464             $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
10465                 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
10466             next unless $inpod;
10467             next if /^=/;
10468             next if /^\s+$/;
10469             chomp;
10470             push @result, $_;
10471         }
10472         close $fh;
10473         last if @result;
10474     }
10475     for (@result) {
10476         s/^\s+//;
10477         s/\s+$//;
10478     }
10479     join " ", @result;
10480 }
10481
10482 #-> sub CPAN::Module::cpan_file ;
10483 # Note: also inherited by CPAN::Bundle
10484 sub cpan_file {
10485     my $self = shift;
10486     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
10487     unless ($self->ro) {
10488         CPAN::Index->reload;
10489     }
10490     my $ro = $self->ro;
10491     if ($ro && defined $ro->{CPAN_FILE}) {
10492         return $ro->{CPAN_FILE};
10493     } else {
10494         my $userid = $self->userid;
10495         if ( $userid ) {
10496             if ($CPAN::META->exists("CPAN::Author",$userid)) {
10497                 my $author = $CPAN::META->instance("CPAN::Author",
10498                                                    $userid);
10499                 my $fullname = $author->fullname;
10500                 my $email = $author->email;
10501                 unless (defined $fullname && defined $email) {
10502                     return sprintf("Contact Author %s",
10503                                    $userid,
10504                                   );
10505                 }
10506                 return "Contact Author $fullname <$email>";
10507             } else {
10508                 return "Contact Author $userid (Email address not available)";
10509             }
10510         } else {
10511             return "N/A";
10512         }
10513     }
10514 }
10515
10516 #-> sub CPAN::Module::cpan_version ;
10517 sub cpan_version {
10518     my $self = shift;
10519
10520     my $ro = $self->ro;
10521     unless ($ro) {
10522         # Can happen with modules that are not on CPAN
10523         $ro = {};
10524     }
10525     $ro->{CPAN_VERSION} = 'undef'
10526         unless defined $ro->{CPAN_VERSION};
10527     $ro->{CPAN_VERSION};
10528 }
10529
10530 #-> sub CPAN::Module::force ;
10531 sub force {
10532     my($self) = @_;
10533     $self->{force_update} = 1;
10534 }
10535
10536 #-> sub CPAN::Module::fforce ;
10537 sub fforce {
10538     my($self) = @_;
10539     $self->{force_update} = 2;
10540 }
10541
10542 #-> sub CPAN::Module::notest ;
10543 sub notest {
10544     my($self) = @_;
10545     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10546     $self->{notest}++;
10547 }
10548
10549 #-> sub CPAN::Module::rematein ;
10550 sub rematein {
10551     my($self,$meth) = @_;
10552     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10553                                      $meth,
10554                                      $self->id));
10555     my $cpan_file = $self->cpan_file;
10556     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10557         $CPAN::Frontend->mywarn(sprintf qq{
10558   The module %s isn\'t available on CPAN.
10559
10560   Either the module has not yet been uploaded to CPAN, or it is
10561   temporary unavailable. Please contact the author to find out
10562   more about the status. Try 'i %s'.
10563 },
10564                                 $self->id,
10565                                 $self->id,
10566                                );
10567         return;
10568     }
10569     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10570     $pack->called_for($self->id);
10571     if (exists $self->{force_update}) {
10572         if ($self->{force_update} == 2) {
10573             $pack->fforce($meth);
10574         } else {
10575             $pack->force($meth);
10576         }
10577     }
10578     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10579
10580     $pack->{reqtype} ||= "";
10581     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10582                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10583         if ($pack->{reqtype}) {
10584             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10585                 $pack->{reqtype} = $self->{reqtype};
10586                 if (
10587                     exists $pack->{install}
10588                     &&
10589                     (
10590                      UNIVERSAL::can($pack->{install},"failed") ?
10591                      $pack->{install}->failed :
10592                      $pack->{install} =~ /^NO/
10593                     )
10594                    ) {
10595                     delete $pack->{install};
10596                     $CPAN::Frontend->mywarn
10597                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10598                 }
10599             }
10600         } else {
10601             $pack->{reqtype} = $self->{reqtype};
10602         }
10603
10604     my $success = eval {
10605         $pack->$meth();
10606     };
10607     my $err = $@;
10608     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10609     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10610     delete $self->{force_update};
10611     delete $self->{notest};
10612     if ($err) {
10613         die $err;
10614     }
10615     return $success;
10616 }
10617
10618 #-> sub CPAN::Module::perldoc ;
10619 sub perldoc { shift->rematein('perldoc') }
10620 #-> sub CPAN::Module::readme ;
10621 sub readme  { shift->rematein('readme') }
10622 #-> sub CPAN::Module::look ;
10623 sub look    { shift->rematein('look') }
10624 #-> sub CPAN::Module::cvs_import ;
10625 sub cvs_import { shift->rematein('cvs_import') }
10626 #-> sub CPAN::Module::get ;
10627 sub get     { shift->rematein('get',@_) }
10628 #-> sub CPAN::Module::make ;
10629 sub make    { shift->rematein('make') }
10630 #-> sub CPAN::Module::test ;
10631 sub test   {
10632     my $self = shift;
10633     # $self->{badtestcnt} ||= 0;
10634     $self->rematein('test',@_);
10635 }
10636
10637 #-> sub CPAN::Module::uptodate ;
10638 sub uptodate {
10639     my ($self) = @_;
10640     local ($_);
10641     my $inst = $self->inst_version or return undef;
10642     my $cpan = $self->cpan_version;
10643     local ($^W) = 0;
10644     CPAN::Version->vgt($cpan,$inst) and return 0;
10645     CPAN->debug(join("",
10646                      "returning uptodate. inst_file[",
10647                      $self->inst_file,
10648                      "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10649     return 1;
10650 }
10651
10652 #-> sub CPAN::Module::install ;
10653 sub install {
10654     my($self) = @_;
10655     my($doit) = 0;
10656     if ($self->uptodate
10657         &&
10658         not exists $self->{force_update}
10659        ) {
10660         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10661                                          $self->id,
10662                                          $self->inst_version,
10663                                         ));
10664     } else {
10665         $doit = 1;
10666     }
10667     my $ro = $self->ro;
10668     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10669         $CPAN::Frontend->mywarn(qq{
10670 \n\n\n     ***WARNING***
10671      The module $self->{ID} has no active maintainer.\n\n\n
10672 });
10673         $CPAN::Frontend->mysleep(5);
10674     }
10675     return $doit ? $self->rematein('install') : 1;
10676 }
10677 #-> sub CPAN::Module::clean ;
10678 sub clean  { shift->rematein('clean') }
10679
10680 #-> sub CPAN::Module::inst_file ;
10681 sub inst_file {
10682     my($self) = @_;
10683     $self->_file_in_path([@INC]);
10684 }
10685
10686 #-> sub CPAN::Module::available_file ;
10687 sub available_file {
10688     my($self) = @_;
10689     my $sep = $Config::Config{path_sep};
10690     my $perllib = $ENV{PERL5LIB};
10691     $perllib = $ENV{PERLLIB} unless defined $perllib;
10692     my @perllib = split(/$sep/,$perllib) if defined $perllib;
10693     my @cpan_perl5inc;
10694     if ($CPAN::Perl5lib_tempfile) {
10695         my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
10696         @cpan_perl5inc = @{$yaml->[0]{inc} || []};
10697     }
10698     $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
10699 }
10700
10701 #-> sub CPAN::Module::file_in_path ;
10702 sub _file_in_path {
10703     my($self,$path) = @_;
10704     my($dir,@packpath);
10705     @packpath = split /::/, $self->{ID};
10706     $packpath[-1] .= ".pm";
10707     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10708         unshift @packpath, "Term", "ReadLine"; # historical reasons
10709     }
10710     foreach $dir (@$path) {
10711         my $pmfile = File::Spec->catfile($dir,@packpath);
10712         if (-f $pmfile) {
10713             return $pmfile;
10714         }
10715     }
10716     return;
10717 }
10718
10719 #-> sub CPAN::Module::xs_file ;
10720 sub xs_file {
10721     my($self) = @_;
10722     my($dir,@packpath);
10723     @packpath = split /::/, $self->{ID};
10724     push @packpath, $packpath[-1];
10725     $packpath[-1] .= "." . $Config::Config{'dlext'};
10726     foreach $dir (@INC) {
10727         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10728         if (-f $xsfile) {
10729             return $xsfile;
10730         }
10731     }
10732     return;
10733 }
10734
10735 #-> sub CPAN::Module::inst_version ;
10736 sub inst_version {
10737     my($self) = @_;
10738     my $parsefile = $self->inst_file or return;
10739     my $have = $self->parse_version($parsefile);
10740     $have;
10741 }
10742
10743 #-> sub CPAN::Module::inst_version ;
10744 sub available_version {
10745     my($self) = @_;
10746     my $parsefile = $self->available_file or return;
10747     my $have = $self->parse_version($parsefile);
10748     $have;
10749 }
10750
10751 #-> sub CPAN::Module::parse_version ;
10752 sub parse_version {
10753     my($self,$parsefile) = @_;
10754     my $have = eval { MM->parse_version($parsefile); };
10755     if ($@) {
10756         $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10757     }
10758     my $leastsanity = eval { defined $have && length $have; };
10759     $have = "undef" unless $leastsanity;
10760     $have =~ s/^ //; # since the %vd hack these two lines here are needed
10761     $have =~ s/ $//; # trailing whitespace happens all the time
10762
10763     $have = CPAN::Version->readable($have);
10764
10765     $have =~ s/\s*//g; # stringify to float around floating point issues
10766     $have; # no stringify needed, \s* above matches always
10767 }
10768
10769 #-> sub CPAN::Module::reports
10770 sub reports {
10771     my($self) = @_;
10772     $self->distribution->reports;
10773 }
10774
10775 package CPAN;
10776 use strict;
10777
10778 1;
10779
10780
10781 __END__
10782
10783 =head1 NAME
10784
10785 CPAN - query, download and build perl modules from CPAN sites
10786
10787 =head1 SYNOPSIS
10788
10789 Interactive mode:
10790
10791   perl -MCPAN -e shell
10792
10793 --or--
10794
10795   cpan
10796
10797 Basic commands:
10798
10799   # Modules:
10800
10801   cpan> install Acme::Meta                       # in the shell
10802
10803   CPAN::Shell->install("Acme::Meta");            # in perl
10804
10805   # Distributions:
10806
10807   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10808
10809   CPAN::Shell->
10810     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10811
10812   # module objects:
10813
10814   $mo = CPAN::Shell->expandany($mod);
10815   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10816
10817   # distribution objects:
10818
10819   $do = CPAN::Shell->expand("Module",$mod)->distribution;
10820   $do = CPAN::Shell->expandany($distro);         # same thing
10821   $do = CPAN::Shell->expand("Distribution",
10822                             $distro);            # same thing
10823
10824 =head1 DESCRIPTION
10825
10826 The CPAN module automates or at least simplifies the make and install
10827 of perl modules and extensions. It includes some primitive searching
10828 capabilities and knows how to use Net::FTP or LWP or some external
10829 download clients to fetch the distributions from the net.
10830
10831 These are fetched from one or more of the mirrored CPAN (Comprehensive
10832 Perl Archive Network) sites and unpacked in a dedicated directory.
10833
10834 The CPAN module also supports the concept of named and versioned
10835 I<bundles> of modules. Bundles simplify the handling of sets of
10836 related modules. See Bundles below.
10837
10838 The package contains a session manager and a cache manager. The
10839 session manager keeps track of what has been fetched, built and
10840 installed in the current session. The cache manager keeps track of the
10841 disk space occupied by the make processes and deletes excess space
10842 according to a simple FIFO mechanism.
10843
10844 All methods provided are accessible in a programmer style and in an
10845 interactive shell style.
10846
10847 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10848
10849 The interactive mode is entered by running
10850
10851     perl -MCPAN -e shell
10852
10853 or
10854
10855     cpan
10856
10857 which puts you into a readline interface. If C<Term::ReadKey> and
10858 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10859 it supports both history and command completion.
10860
10861 Once you are on the command line, type C<h> to get a one page help
10862 screen and the rest should be self-explanatory.
10863
10864 The function call C<shell> takes two optional arguments, one is the
10865 prompt, the second is the default initial command line (the latter
10866 only works if a real ReadLine interface module is installed).
10867
10868 The most common uses of the interactive modes are
10869
10870 =over 2
10871
10872 =item Searching for authors, bundles, distribution files and modules
10873
10874 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10875 for each of the four categories and another, C<i> for any of the
10876 mentioned four. Each of the four entities is implemented as a class
10877 with slightly differing methods for displaying an object.
10878
10879 Arguments you pass to these commands are either strings exactly matching
10880 the identification string of an object or regular expressions that are
10881 then matched case-insensitively against various attributes of the
10882 objects. The parser recognizes a regular expression only if you
10883 enclose it between two slashes.
10884
10885 The principle is that the number of found objects influences how an
10886 item is displayed. If the search finds one item, the result is
10887 displayed with the rather verbose method C<as_string>, but if we find
10888 more than one, we display each object with the terse method
10889 C<as_glimpse>.
10890
10891 Examples:
10892
10893   cpan> m Acme::MetaSyntactic
10894   Module id = Acme::MetaSyntactic
10895       CPAN_USERID  BOOK (Philippe Bruhat (BooK) <[...]>)
10896       CPAN_VERSION 0.99
10897       CPAN_FILE    B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10898       UPLOAD_DATE  2006-11-06
10899       MANPAGE      Acme::MetaSyntactic - Themed metasyntactic variables names
10900       INST_FILE    /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
10901       INST_VERSION 0.99
10902   cpan> a BOOK
10903   Author id = BOOK
10904       EMAIL        [...]
10905       FULLNAME     Philippe Bruhat (BooK)
10906   cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
10907   Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10908       CPAN_USERID  BOOK (Philippe Bruhat (BooK) <[...]>)
10909       CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
10910       UPLOAD_DATE  2006-11-06
10911   cpan> m /lorem/
10912   Module  = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
10913   Module    Text::Lorem            (ADEOLA/Text-Lorem-0.3.tar.gz)
10914   Module    Text::Lorem::More      (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10915   Module    Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10916   cpan> i /berlin/
10917   Distribution    BEATNIK/Filter-NumberLines-0.02.tar.gz
10918   Module  = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
10919   Module    Filter::NumberLines    (BEATNIK/Filter-NumberLines-0.02.tar.gz)
10920   Author          [...]
10921
10922 The examples illustrate several aspects: the first three queries
10923 target modules, authors, or distros directly and yield exactly one
10924 result. The last two use regular expressions and yield several
10925 results. The last one targets all of bundles, modules, authors, and
10926 distros simultaneously. When more than one result is available, they
10927 are printed in one-line format.
10928
10929 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10930
10931 These commands take any number of arguments and investigate what is
10932 necessary to perform the action. If the argument is a distribution
10933 file name (recognized by embedded slashes), it is processed. If it is
10934 a module, CPAN determines the distribution file in which this module
10935 is included and processes that, following any dependencies named in
10936 the module's META.yml or Makefile.PL (this behavior is controlled by
10937 the configuration parameter C<prerequisites_policy>.)
10938
10939 C<get> downloads a distribution file and untars or unzips it, C<make>
10940 builds it, C<test> runs the test suite, and C<install> installs it.
10941
10942 Any C<make> or C<test> are run unconditionally. An
10943
10944   install <distribution_file>
10945
10946 also is run unconditionally. But for
10947
10948   install <module>
10949
10950 CPAN checks if an install is actually needed for it and prints
10951 I<module up to date> in the case that the distribution file containing
10952 the module doesn't need to be updated.
10953
10954 CPAN also keeps track of what it has done within the current session
10955 and doesn't try to build a package a second time regardless if it
10956 succeeded or not. It does not repeat a test run if the test
10957 has been run successfully before. Same for install runs.
10958
10959 The C<force> pragma may precede another command (currently: C<get>,
10960 C<make>, C<test>, or C<install>) and executes the command from scratch
10961 and tries to continue in case of some errors. See the section below on
10962 the C<force> and the C<fforce> pragma.
10963
10964 The C<notest> pragma may be used to skip the test part in the build
10965 process.
10966
10967 Example:
10968
10969     cpan> notest install Tk
10970
10971 A C<clean> command results in a
10972
10973   make clean
10974
10975 being executed within the distribution file's working directory.
10976
10977 =item C<readme>, C<perldoc>, C<look> module or distribution
10978
10979 C<readme> displays the README file of the associated distribution.
10980 C<Look> gets and untars (if not yet done) the distribution file,
10981 changes to the appropriate directory and opens a subshell process in
10982 that directory. C<perldoc> displays the pod documentation of the
10983 module in html or plain text format.
10984
10985 =item C<ls> author
10986
10987 =item C<ls> globbing_expression
10988
10989 The first form lists all distribution files in and below an author's
10990 CPAN directory as they are stored in the CHECKUMS files distributed on
10991 CPAN. The listing goes recursive into all subdirectories.
10992
10993 The second form allows to limit or expand the output with shell
10994 globbing as in the following examples:
10995
10996       ls JV/make*
10997       ls GSAR/*make*
10998       ls */*make*
10999
11000 The last example is very slow and outputs extra progress indicators
11001 that break the alignment of the result.
11002
11003 Note that globbing only lists directories explicitly asked for, for
11004 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
11005 regarded as a bug and may be changed in future versions.
11006
11007 =item C<failed>
11008
11009 The C<failed> command reports all distributions that failed on one of
11010 C<make>, C<test> or C<install> for some reason in the currently
11011 running shell session.
11012
11013 =item Persistence between sessions
11014
11015 If the C<YAML> or the C<YAML::Syck> module is installed a record of
11016 the internal state of all modules is written to disk after each step.
11017 The files contain a signature of the currently running perl version
11018 for later perusal.
11019
11020 If the configurations variable C<build_dir_reuse> is set to a true
11021 value, then CPAN.pm reads the collected YAML files. If the stored
11022 signature matches the currently running perl the stored state is
11023 loaded into memory such that effectively persistence between sessions
11024 is established.
11025
11026 =item The C<force> and the C<fforce> pragma
11027
11028 To speed things up in complex installation scenarios, CPAN.pm keeps
11029 track of what it has already done and refuses to do some things a
11030 second time. A C<get>, a C<make>, and an C<install> are not repeated.
11031 A C<test> is only repeated if the previous test was unsuccessful. The
11032 diagnostic message when CPAN.pm refuses to do something a second time
11033 is one of I<Has already been >C<unwrapped|made|tested successfully> or
11034 something similar. Another situation where CPAN refuses to act is an
11035 C<install> if the according C<test> was not successful.
11036
11037 In all these cases, the user can override the goatish behaviour by
11038 prepending the command with the word force, for example:
11039
11040   cpan> force get Foo
11041   cpan> force make AUTHOR/Bar-3.14.tar.gz
11042   cpan> force test Baz
11043   cpan> force install Acme::Meta
11044
11045 Each I<forced> command is executed with the according part of its
11046 memory erased.
11047
11048 The C<fforce> pragma is a variant that emulates a C<force get> which
11049 erases the entire memory followed by the action specified, effectively
11050 restarting the whole get/make/test/install procedure from scratch.
11051
11052 =item Lockfile
11053
11054 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
11055 Batch jobs can run without a lockfile and do not disturb each other.
11056
11057 The shell offers to run in I<degraded mode> when another process is
11058 holding the lockfile. This is an experimental feature that is not yet
11059 tested very well. This second shell then does not write the history
11060 file, does not use the metadata file and has a different prompt.
11061
11062 =item Signals
11063
11064 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
11065 in the cpan-shell it is intended that you can press C<^C> anytime and
11066 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
11067 to clean up and leave the shell loop. You can emulate the effect of a
11068 SIGTERM by sending two consecutive SIGINTs, which usually means by
11069 pressing C<^C> twice.
11070
11071 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
11072 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
11073 Build.PL> subprocess.
11074
11075 =back
11076
11077 =head2 CPAN::Shell
11078
11079 The commands that are available in the shell interface are methods in
11080 the package CPAN::Shell. If you enter the shell command, all your
11081 input is split by the Text::ParseWords::shellwords() routine which
11082 acts like most shells do. The first word is being interpreted as the
11083 method to be called and the rest of the words are treated as arguments
11084 to this method. Continuation lines are supported if a line ends with a
11085 literal backslash.
11086
11087 =head2 autobundle
11088
11089 C<autobundle> writes a bundle file into the
11090 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
11091 a list of all modules that are both available from CPAN and currently
11092 installed within @INC. The name of the bundle file is based on the
11093 current date and a counter.
11094
11095 =head2 hosts
11096
11097 Note: this feature is still in alpha state and may change in future
11098 versions of CPAN.pm
11099
11100 This commands provides a statistical overview over recent download
11101 activities. The data for this is collected in the YAML file
11102 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
11103 configured or YAML not installed, then no stats are provided.
11104
11105 =head2 mkmyconfig
11106
11107 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
11108 directory so that you can save your own preferences instead of the
11109 system wide ones.
11110
11111 =head2 recent ***EXPERIMENTAL COMMAND***
11112
11113 The C<recent> command downloads a list of recent uploads to CPAN and
11114 displays them I<slowly>. While the command is running $SIG{INT} is
11115 defined to mean that the loop shall be left after having displayed the
11116 current item.
11117
11118 B<Note>: This command requires XML::LibXML installed.
11119
11120 B<Note>: This whole command currently is just a hack and will
11121 probably change in future versions of CPAN.pm but the general
11122 approach will likely stay.
11123
11124 B<Note>: See also L<smoke>
11125
11126 =head2 recompile
11127
11128 recompile() is a very special command in that it takes no argument and
11129 runs the make/test/install cycle with brute force over all installed
11130 dynamically loadable extensions (aka XS modules) with 'force' in
11131 effect. The primary purpose of this command is to finish a network
11132 installation. Imagine, you have a common source tree for two different
11133 architectures. You decide to do a completely independent fresh
11134 installation. You start on one architecture with the help of a Bundle
11135 file produced earlier. CPAN installs the whole Bundle for you, but
11136 when you try to repeat the job on the second architecture, CPAN
11137 responds with a C<"Foo up to date"> message for all modules. So you
11138 invoke CPAN's recompile on the second architecture and you're done.
11139
11140 Another popular use for C<recompile> is to act as a rescue in case your
11141 perl breaks binary compatibility. If one of the modules that CPAN uses
11142 is in turn depending on binary compatibility (so you cannot run CPAN
11143 commands), then you should try the CPAN::Nox module for recovery.
11144
11145 =head2 report Bundle|Distribution|Module
11146
11147 The C<report> command temporarily turns on the C<test_report> config
11148 variable, then runs the C<force test> command with the given
11149 arguments. The C<force> pragma is used to re-run the tests and repeat
11150 every step that might have failed before.
11151
11152 =head2 smoke ***EXPERIMENTAL COMMAND***
11153
11154 B<*** WARNING: this command downloads and executes software from CPAN to
11155 your computer of completely unknown status. You should never do
11156 this with your normal account and better have a dedicated well
11157 separated and secured machine to do this. ***>
11158
11159 The C<smoke> command takes the list of recent uploads to CPAN as
11160 provided by the C<recent> command and tests them all. While the
11161 command is running $SIG{INT} is defined to mean that the current item
11162 shall be skipped.
11163
11164 B<Note>: This whole command currently is just a hack and will
11165 probably change in future versions of CPAN.pm but the general
11166 approach will likely stay.
11167
11168 B<Note>: See also L<recent>
11169
11170 =head2 upgrade [Module|/Regex/]...
11171
11172 The C<upgrade> command first runs an C<r> command with the given
11173 arguments and then installs the newest versions of all modules that
11174 were listed by that.
11175
11176 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
11177
11178 Although it may be considered internal, the class hierarchy does matter
11179 for both users and programmer. CPAN.pm deals with above mentioned four
11180 classes, and all those classes share a set of methods. A classical
11181 single polymorphism is in effect. A metaclass object registers all
11182 objects of all kinds and indexes them with a string. The strings
11183 referencing objects have a separated namespace (well, not completely
11184 separated):
11185
11186          Namespace                         Class
11187
11188    words containing a "/" (slash)      Distribution
11189     words starting with Bundle::          Bundle
11190           everything else            Module or Author
11191
11192 Modules know their associated Distribution objects. They always refer
11193 to the most recent official release. Developers may mark their releases
11194 as unstable development versions (by inserting an underbar into the
11195 module version number which will also be reflected in the distribution
11196 name when you run 'make dist'), so the really hottest and newest
11197 distribution is not always the default.  If a module Foo circulates
11198 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
11199 way to install version 1.23 by saying
11200
11201     install Foo
11202
11203 This would install the complete distribution file (say
11204 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
11205 like to install version 1.23_90, you need to know where the
11206 distribution file resides on CPAN relative to the authors/id/
11207 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
11208 so you would have to say
11209
11210     install BAR/Foo-1.23_90.tar.gz
11211
11212 The first example will be driven by an object of the class
11213 CPAN::Module, the second by an object of class CPAN::Distribution.
11214
11215 =head2 Integrating local directories
11216
11217 Note: this feature is still in alpha state and may change in future
11218 versions of CPAN.pm
11219
11220 Distribution objects are normally distributions from the CPAN, but
11221 there is a slightly degenerate case for Distribution objects, too, of
11222 projects held on the local disk. These distribution objects have the
11223 same name as the local directory and end with a dot. A dot by itself
11224 is also allowed for the current directory at the time CPAN.pm was
11225 used. All actions such as C<make>, C<test>, and C<install> are applied
11226 directly to that directory. This gives the command C<cpan .> an
11227 interesting touch: while the normal mantra of installing a CPAN module
11228 without CPAN.pm is one of
11229
11230     perl Makefile.PL                 perl Build.PL
11231            ( go and get prerequisites )
11232     make                             ./Build
11233     make test                        ./Build test
11234     make install                     ./Build install
11235
11236 the command C<cpan .> does all of this at once. It figures out which
11237 of the two mantras is appropriate, fetches and installs all
11238 prerequisites, cares for them recursively and finally finishes the
11239 installation of the module in the current directory, be it a CPAN
11240 module or not.
11241
11242 The typical usage case is for private modules or working copies of
11243 projects from remote repositories on the local disk.
11244
11245 =head2 Redirection
11246
11247 The usual shell redirection symbols C< | > and C<< > >> are recognized
11248 by the cpan shell when surrounded by whitespace. So piping into a
11249 pager and redirecting output into a file works quite similar to any
11250 shell.
11251
11252 =head1 CONFIGURATION
11253
11254 When the CPAN module is used for the first time, a configuration
11255 dialog tries to determine a couple of site specific options. The
11256 result of the dialog is stored in a hash reference C< $CPAN::Config >
11257 in a file CPAN/Config.pm.
11258
11259 The default values defined in the CPAN/Config.pm file can be
11260 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
11261 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
11262 added to the search path of the CPAN module before the use() or
11263 require() statements. The mkmyconfig command writes this file for you.
11264
11265 The C<o conf> command has various bells and whistles:
11266
11267 =over
11268
11269 =item completion support
11270
11271 If you have a ReadLine module installed, you can hit TAB at any point
11272 of the commandline and C<o conf> will offer you completion for the
11273 built-in subcommands and/or config variable names.
11274
11275 =item displaying some help: o conf help
11276
11277 Displays a short help
11278
11279 =item displaying current values: o conf [KEY]
11280
11281 Displays the current value(s) for this config variable. Without KEY
11282 displays all subcommands and config variables.
11283
11284 Example:
11285
11286   o conf shell
11287
11288 If KEY starts and ends with a slash the string in between is
11289 interpreted as a regular expression and only keys matching this regex
11290 are displayed
11291
11292 Example:
11293
11294   o conf /color/
11295
11296 =item changing of scalar values: o conf KEY VALUE
11297
11298 Sets the config variable KEY to VALUE. The empty string can be
11299 specified as usual in shells, with C<''> or C<"">
11300
11301 Example:
11302
11303   o conf wget /usr/bin/wget
11304
11305 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
11306
11307 If a config variable name ends with C<list>, it is a list. C<o conf
11308 KEY shift> removes the first element of the list, C<o conf KEY pop>
11309 removes the last element of the list. C<o conf KEYS unshift LIST>
11310 prepends a list of values to the list, C<o conf KEYS push LIST>
11311 appends a list of valued to the list.
11312
11313 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
11314 splice command.
11315
11316 Finally, any other list of arguments is taken as a new list value for
11317 the KEY variable discarding the previous value.
11318
11319 Examples:
11320
11321   o conf urllist unshift http://cpan.dev.local/CPAN
11322   o conf urllist splice 3 1
11323   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
11324
11325 =item reverting to saved: o conf defaults
11326
11327 Reverts all config variables to the state in the saved config file.
11328
11329 =item saving the config: o conf commit
11330
11331 Saves all config variables to the current config file (CPAN/Config.pm
11332 or CPAN/MyConfig.pm that was loaded at start).
11333
11334 =back
11335
11336 The configuration dialog can be started any time later again by
11337 issuing the command C< o conf init > in the CPAN shell. A subset of
11338 the configuration dialog can be run by issuing C<o conf init WORD>
11339 where WORD is any valid config variable or a regular expression.
11340
11341 =head2 Config Variables
11342
11343 Currently the following keys in the hash reference $CPAN::Config are
11344 defined:
11345
11346   applypatch         path to external prg
11347   auto_commit        commit all changes to config variables to disk
11348   build_cache        size of cache for directories to build modules
11349   build_dir          locally accessible directory to build modules
11350   build_dir_reuse    boolean if distros in build_dir are persistent
11351   build_requires_install_policy
11352                      to install or not to install when a module is
11353                      only needed for building. yes|no|ask/yes|ask/no
11354   bzip2              path to external prg
11355   cache_metadata     use serializer to cache metadata
11356   check_sigs         if signatures should be verified
11357   colorize_debug     Term::ANSIColor attributes for debugging output
11358   colorize_output    boolean if Term::ANSIColor should colorize output
11359   colorize_print     Term::ANSIColor attributes for normal output
11360   colorize_warn      Term::ANSIColor attributes for warnings
11361   commandnumber_in_prompt
11362                      boolean if you want to see current command number
11363   commands_quote     prefered character to use for quoting external
11364                      commands when running them. Defaults to double
11365                      quote on Windows, single tick everywhere else;
11366                      can be set to space to disable quoting
11367   connect_to_internet_ok
11368                      if we shall ask if opening a connection is ok before
11369                      urllist is specified
11370   cpan_home          local directory reserved for this package
11371   curl               path to external prg
11372   dontload_hash      DEPRECATED
11373   dontload_list      arrayref: modules in the list will not be
11374                      loaded by the CPAN::has_inst() routine
11375   ftp                path to external prg
11376   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
11377   ftp_proxy          proxy host for ftp requests
11378   ftpstats_period    max number of days to keep download statistics
11379   ftpstats_size      max number of items to keep in the download statistics
11380   getcwd             see below
11381   gpg                path to external prg
11382   gzip               location of external program gzip
11383   halt_on_failure    stop processing after the first failure of queued
11384                      items or dependencies
11385   histfile           file to maintain history between sessions
11386   histsize           maximum number of lines to keep in histfile
11387   http_proxy         proxy host for http requests
11388   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
11389                      after this many seconds inactivity. Set to 0 to
11390                      never break.
11391   index_expire       after this many days refetch index files
11392   inhibit_startup_message
11393                      if true, does not print the startup message
11394   keep_source_where  directory in which to keep the source (if we do)
11395   load_module_verbosity
11396                      report loading of optional modules used by CPAN.pm
11397   lynx               path to external prg
11398   make               location of external make program
11399   make_arg           arguments that should always be passed to 'make'
11400   make_install_make_command
11401                      the make command for running 'make install', for
11402                      example 'sudo make'
11403   make_install_arg   same as make_arg for 'make install'
11404   makepl_arg         arguments passed to 'perl Makefile.PL'
11405   mbuild_arg         arguments passed to './Build'
11406   mbuild_install_arg arguments passed to './Build install'
11407   mbuild_install_build_command
11408                      command to use instead of './Build' when we are
11409                      in the install stage, for example 'sudo ./Build'
11410   mbuildpl_arg       arguments passed to 'perl Build.PL'
11411   ncftp              path to external prg
11412   ncftpget           path to external prg
11413   no_proxy           don't proxy to these hosts/domains (comma separated list)
11414   pager              location of external program more (or any pager)
11415   password           your password if you CPAN server wants one
11416   patch              path to external prg
11417   perl5lib_verbosity verbosity level for PERL5LIB additions
11418   prefer_installer   legal values are MB and EUMM: if a module comes
11419                      with both a Makefile.PL and a Build.PL, use the
11420                      former (EUMM) or the latter (MB); if the module
11421                      comes with only one of the two, that one will be
11422                      used in any case
11423   prerequisites_policy
11424                      what to do if you are missing module prerequisites
11425                      ('follow' automatically, 'ask' me, or 'ignore')
11426   prefs_dir          local directory to store per-distro build options
11427   proxy_user         username for accessing an authenticating proxy
11428   proxy_pass         password for accessing an authenticating proxy
11429   randomize_urllist  add some randomness to the sequence of the urllist
11430   scan_cache         controls scanning of cache ('atstart' or 'never')
11431   shell              your favorite shell
11432   show_unparsable_versions
11433                      boolean if r command tells which modules are versionless
11434   show_upload_date   boolean if commands should try to determine upload date
11435   show_zero_versions boolean if r command tells for which modules $version==0
11436   tar                location of external program tar
11437   tar_verbosity      verbosity level for the tar command
11438   term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
11439                      (and nonsense for characters outside latin range)
11440   term_ornaments     boolean to turn ReadLine ornamenting on/off
11441   test_report        email test reports (if CPAN::Reporter is installed)
11442   trust_test_report_history
11443                      skip testing when previously tested ok (according to
11444                      CPAN::Reporter history)
11445   unzip              location of external program unzip
11446   urllist            arrayref to nearby CPAN sites (or equivalent locations)
11447   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
11448   username           your username if you CPAN server wants one
11449   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
11450   wget               path to external prg
11451   yaml_load_code     enable YAML code deserialisation via CPAN::DeferedCode
11452   yaml_module        which module to use to read/write YAML files
11453
11454 You can set and query each of these options interactively in the cpan
11455 shell with the C<o conf> or the C<o conf init> command as specified below.
11456
11457 =over 2
11458
11459 =item C<o conf E<lt>scalar optionE<gt>>
11460
11461 prints the current value of the I<scalar option>
11462
11463 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
11464
11465 Sets the value of the I<scalar option> to I<value>
11466
11467 =item C<o conf E<lt>list optionE<gt>>
11468
11469 prints the current value of the I<list option> in MakeMaker's
11470 neatvalue format.
11471
11472 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
11473
11474 shifts or pops the array in the I<list option> variable
11475
11476 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
11477
11478 works like the corresponding perl commands.
11479
11480 =item interactive editing: o conf init [MATCH|LIST]
11481
11482 Runs an interactive configuration dialog for matching variables.
11483 Without argument runs the dialog over all supported config variables.
11484 To specify a MATCH the argument must be enclosed by slashes.
11485
11486 Examples:
11487
11488   o conf init ftp_passive ftp_proxy
11489   o conf init /color/
11490
11491 Note: this method of setting config variables often provides more
11492 explanation about the functioning of a variable than the manpage.
11493
11494 =back
11495
11496 =head2 CPAN::anycwd($path): Note on config variable getcwd
11497
11498 CPAN.pm changes the current working directory often and needs to
11499 determine its own current working directory. Per default it uses
11500 Cwd::cwd but if this doesn't work on your system for some reason,
11501 alternatives can be configured according to the following table:
11502
11503 =over 4
11504
11505 =item cwd
11506
11507 Calls Cwd::cwd
11508
11509 =item getcwd
11510
11511 Calls Cwd::getcwd
11512
11513 =item fastcwd
11514
11515 Calls Cwd::fastcwd
11516
11517 =item backtickcwd
11518
11519 Calls the external command cwd.
11520
11521 =back
11522
11523 =head2 Note on the format of the urllist parameter
11524
11525 urllist parameters are URLs according to RFC 1738. We do a little
11526 guessing if your URL is not compliant, but if you have problems with
11527 C<file> URLs, please try the correct format. Either:
11528
11529     file://localhost/whatever/ftp/pub/CPAN/
11530
11531 or
11532
11533     file:///home/ftp/pub/CPAN/
11534
11535 =head2 The urllist parameter has CD-ROM support
11536
11537 The C<urllist> parameter of the configuration table contains a list of
11538 URLs that are to be used for downloading. If the list contains any
11539 C<file> URLs, CPAN always tries to get files from there first. This
11540 feature is disabled for index files. So the recommendation for the
11541 owner of a CD-ROM with CPAN contents is: include your local, possibly
11542 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
11543
11544   o conf urllist push file://localhost/CDROM/CPAN
11545
11546 CPAN.pm will then fetch the index files from one of the CPAN sites
11547 that come at the beginning of urllist. It will later check for each
11548 module if there is a local copy of the most recent version.
11549
11550 Another peculiarity of urllist is that the site that we could
11551 successfully fetch the last file from automatically gets a preference
11552 token and is tried as the first site for the next request. So if you
11553 add a new site at runtime it may happen that the previously preferred
11554 site will be tried another time. This means that if you want to disallow
11555 a site for the next transfer, it must be explicitly removed from
11556 urllist.
11557
11558 =head2 Maintaining the urllist parameter
11559
11560 If you have YAML.pm (or some other YAML module configured in
11561 C<yaml_module>) installed, CPAN.pm collects a few statistical data
11562 about recent downloads. You can view the statistics with the C<hosts>
11563 command or inspect them directly by looking into the C<FTPstats.yml>
11564 file in your C<cpan_home> directory.
11565
11566 To get some interesting statistics it is recommended to set the
11567 C<randomize_urllist> parameter that introduces some amount of
11568 randomness into the URL selection.
11569
11570 =head2 The C<requires> and C<build_requires> dependency declarations
11571
11572 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11573 a distribution are treated differently depending on the config
11574 variable C<build_requires_install_policy>. By setting
11575 C<build_requires_install_policy> to C<no> such a module is not being
11576 installed. It is only built and tested and then kept in the list of
11577 tested but uninstalled modules. As such it is available during the
11578 build of the dependent module by integrating the path to the
11579 C<blib/arch> and C<blib/lib> directories in the environment variable
11580 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11581 both modules declared as C<requires> and those declared as
11582 C<build_requires> are treated alike. By setting to C<ask/yes> or
11583 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11584
11585 =head2 Configuration for individual distributions (I<Distroprefs>)
11586
11587 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11588 still considered beta quality)
11589
11590 Distributions on the CPAN usually behave according to what we call the
11591 CPAN mantra. Or since the event of Module::Build we should talk about
11592 two mantras:
11593
11594     perl Makefile.PL     perl Build.PL
11595     make                 ./Build
11596     make test            ./Build test
11597     make install         ./Build install
11598
11599 But some modules cannot be built with this mantra. They try to get
11600 some extra data from the user via the environment, extra arguments or
11601 interactively thus disturbing the installation of large bundles like
11602 Phalanx100 or modules with many dependencies like Plagger.
11603
11604 The distroprefs system of C<CPAN.pm> addresses this problem by
11605 allowing the user to specify extra informations and recipes in YAML
11606 files to either
11607
11608 =over
11609
11610 =item
11611
11612 pass additional arguments to one of the four commands,
11613
11614 =item
11615
11616 set environment variables
11617
11618 =item
11619
11620 instantiate an Expect object that reads from the console, waits for
11621 some regular expressions and enters some answers
11622
11623 =item
11624
11625 temporarily override assorted C<CPAN.pm> configuration variables
11626
11627 =item
11628
11629 specify dependencies that the original maintainer forgot to specify
11630
11631 =item
11632
11633 disable the installation of an object altogether
11634
11635 =back
11636
11637 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11638 distribution in the C<distroprefs/> directory for examples.
11639
11640 =head2 Filenames
11641
11642 The YAML files themselves must have the C<.yml> extension, all other
11643 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11644 Storable> below). The containing directory can be specified in
11645 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11646 prefs_dir> in the CPAN shell to set and activate the distroprefs
11647 system.
11648
11649 Every YAML file may contain arbitrary documents according to the YAML
11650 specification and every single document is treated as an entity that
11651 can specify the treatment of a single distribution.
11652
11653 The names of the files can be picked freely, C<CPAN.pm> always reads
11654 all files (in alphabetical order) and takes the key C<match> (see
11655 below in I<Language Specs>) as a hashref containing match criteria
11656 that determine if the current distribution matches the YAML document
11657 or not.
11658
11659 =head2 Fallback Data::Dumper and Storable
11660
11661 If neither your configured C<yaml_module> nor YAML.pm is installed
11662 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11663 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11664 directory. These files are expected to contain one or more hashrefs.
11665 For Data::Dumper generated files, this is expected to be done with by
11666 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11667 with the command
11668
11669     ysh < somefile.yml > somefile.dd
11670
11671 For Storable files the rule is that they must be constructed such that
11672 C<Storable::retrieve(file)> returns an array reference and the array
11673 elements represent one distropref object each. The conversion from
11674 YAML would look like so:
11675
11676     perl -MYAML=LoadFile -MStorable=nstore -e '
11677         @y=LoadFile(shift);
11678         nstore(\@y, shift)' somefile.yml somefile.st
11679
11680 In bootstrapping situations it is usually sufficient to translate only
11681 a few YAML files to Data::Dumper for the crucial modules like
11682 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11683 over Data::Dumper, remember to pull out a Storable version that writes
11684 an older format than all the other Storable versions that will need to
11685 read them.
11686
11687 =head2 Blueprint
11688
11689 The following example contains all supported keywords and structures
11690 with the exception of C<eexpect> which can be used instead of
11691 C<expect>.
11692
11693   ---
11694   comment: "Demo"
11695   match:
11696     module: "Dancing::Queen"
11697     distribution: "^CHACHACHA/Dancing-"
11698     perl: "/usr/local/cariba-perl/bin/perl"
11699     perlconfig:
11700       archname: "freebsd"
11701     env:
11702       DANCING_FLOOR: "Shubiduh"
11703   disabled: 1
11704   cpanconfig:
11705     make: gmake
11706   pl:
11707     args:
11708       - "--somearg=specialcase"
11709
11710     env: {}
11711
11712     expect:
11713       - "Which is your favorite fruit"
11714       - "apple\n"
11715
11716   make:
11717     args:
11718       - all
11719       - extra-all
11720
11721     env: {}
11722
11723     expect: []
11724
11725     commendline: "echo SKIPPING make"
11726
11727   test:
11728     args: []
11729
11730     env: {}
11731
11732     expect: []
11733
11734   install:
11735     args: []
11736
11737     env:
11738       WANT_TO_INSTALL: YES
11739
11740     expect:
11741       - "Do you really want to install"
11742       - "y\n"
11743
11744   patches:
11745     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11746
11747   depends:
11748     configure_requires:
11749       LWP: 5.8
11750     build_requires:
11751       Test::Exception: 0.25
11752     requires:
11753       Spiffy: 0.30
11754
11755
11756 =head2 Language Specs
11757
11758 Every YAML document represents a single hash reference. The valid keys
11759 in this hash are as follows:
11760
11761 =over
11762
11763 =item comment [scalar]
11764
11765 A comment
11766
11767 =item cpanconfig [hash]
11768
11769 Temporarily override assorted C<CPAN.pm> configuration variables.
11770
11771 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11772 C<make>, C<make_install_make_command>, C<prefer_installer>,
11773 C<test_report>. Please report as a bug when you need another one
11774 supported.
11775
11776 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11777
11778 All three types, namely C<configure_requires>, C<build_requires>, and
11779 C<requires> are supported in the way specified in the META.yml
11780 specification. The current implementation I<merges> the specified
11781 dependencies with those declared by the package maintainer. In a
11782 future implementation this may be changed to override the original
11783 declaration.
11784
11785 =item disabled [boolean]
11786
11787 Specifies that this distribution shall not be processed at all.
11788
11789 =item features [array] *** EXPERIMENTAL FEATURE ***
11790
11791 Experimental implementation to deal with optional_features from
11792 META.yml. Still needs coordination with installer software and
11793 currently only works for META.yml declaring C<dynamic_config=0>. Use
11794 with caution.
11795
11796 =item goto [string]
11797
11798 The canonical name of a delegate distribution that shall be installed
11799 instead. Useful when a new version, although it tests OK itself,
11800 breaks something else or a developer release or a fork is already
11801 uploaded that is better than the last released version.
11802
11803 =item install [hash]
11804
11805 Processing instructions for the C<make install> or C<./Build install>
11806 phase of the CPAN mantra. See below under I<Processing Instructions>.
11807
11808 =item make [hash]
11809
11810 Processing instructions for the C<make> or C<./Build> phase of the
11811 CPAN mantra. See below under I<Processing Instructions>.
11812
11813 =item match [hash]
11814
11815 A hashref with one or more of the keys C<distribution>, C<modules>,
11816 C<perl>, C<perlconfig>, and C<env> that specify if a document is
11817 targeted at a specific CPAN distribution or installation.
11818
11819 The corresponding values are interpreted as regular expressions. The
11820 C<distribution> related one will be matched against the canonical
11821 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11822
11823 The C<module> related one will be matched against I<all> modules
11824 contained in the distribution until one module matches.
11825
11826 The C<perl> related one will be matched against C<$^X> (but with the
11827 absolute path).
11828
11829 The value associated with C<perlconfig> is itself a hashref that is
11830 matched against corresponding values in the C<%Config::Config> hash
11831 living in the C<Config.pm> module.
11832
11833 The value associated with C<env> is itself a hashref that is
11834 matched against corresponding values in the C<%ENV> hash.
11835
11836 If more than one restriction of C<module>, C<distribution>, etc. is
11837 specified, the results of the separately computed match values must
11838 all match. If this is the case then the hashref represented by the
11839 YAML document is returned as the preference structure for the current
11840 distribution.
11841
11842 =item patches [array]
11843
11844 An array of patches on CPAN or on the local disk to be applied in
11845 order via the external patch program. If the value for the C<-p>
11846 parameter is C<0> or C<1> is determined by reading the patch
11847 beforehand.
11848
11849 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11850 knows about it B<and> a patch is written by the C<makepatch> program,
11851 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11852 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11853 distribution.
11854
11855 =item pl [hash]
11856
11857 Processing instructions for the C<perl Makefile.PL> or C<perl
11858 Build.PL> phase of the CPAN mantra. See below under I<Processing
11859 Instructions>.
11860
11861 =item test [hash]
11862
11863 Processing instructions for the C<make test> or C<./Build test> phase
11864 of the CPAN mantra. See below under I<Processing Instructions>.
11865
11866 =back
11867
11868 =head2 Processing Instructions
11869
11870 =over
11871
11872 =item args [array]
11873
11874 Arguments to be added to the command line
11875
11876 =item commandline
11877
11878 A full commandline that will be executed as it stands by a system
11879 call. During the execution the environment variable PERL will is set
11880 to $^X (but with an absolute path). If C<commandline> is specified,
11881 the content of C<args> is not used.
11882
11883 =item eexpect [hash]
11884
11885 Extended C<expect>. This is a hash reference with four allowed keys,
11886 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11887
11888 C<mode> may have the values C<deterministic> for the case where all
11889 questions come in the order written down and C<anyorder> for the case
11890 where the questions may come in any order. The default mode is
11891 C<deterministic>.
11892
11893 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11894 OK. In the case of a C<mode=deterministic> the timeout denotes the
11895 timeout per question, in the case of C<mode=anyorder> it denotes the
11896 timeout per byte received from the stream or questions.
11897
11898 C<talk> is a reference to an array that contains alternating questions
11899 and answers. Questions are regular expressions and answers are literal
11900 strings. The Expect module will then watch the stream coming from the
11901 execution of the external program (C<perl Makefile.PL>, C<perl
11902 Build.PL>, C<make>, etc.).
11903
11904 In the case of C<mode=deterministic> the CPAN.pm will inject the
11905 according answer as soon as the stream matches the regular expression.
11906
11907 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11908 as the timeout is reached for the next byte in the input stream. In
11909 this mode you can use the C<reuse> parameter to decide what shall
11910 happen with a question-answer pair after it has been used. In the
11911 default case (reuse=0) it is removed from the array, so it cannot be
11912 used again accidentally. In this case, if you want to answer the
11913 question C<Do you really want to do that> several times, then it must
11914 be included in the array at least as often as you want this answer to
11915 be given. Setting the parameter C<reuse> to 1 makes this repetition
11916 unnecessary.
11917
11918 =item env [hash]
11919
11920 Environment variables to be set during the command
11921
11922 =item expect [array]
11923
11924 C<< expect: <array> >> is a short notation for
11925
11926   eexpect:
11927     mode: deterministic
11928     timeout: 15
11929     talk: <array>
11930
11931 =back
11932
11933 =head2 Schema verification with C<Kwalify>
11934
11935 If you have the C<Kwalify> module installed (which is part of the
11936 Bundle::CPANxxl), then all your distroprefs files are checked for
11937 syntactical correctness.
11938
11939 =head2 Example Distroprefs Files
11940
11941 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11942 are really just examples and should not be used without care because
11943 they cannot fit everybody's purpose. After all the authors of the
11944 packages that ask questions had a need to ask, so you should watch
11945 their questions and adjust the examples to your environment and your
11946 needs. You have beend warned:-)
11947
11948 =head1 PROGRAMMER'S INTERFACE
11949
11950 If you do not enter the shell, the available shell commands are both
11951 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11952 functions in the calling package (C<install(...)>).  Before calling low-level
11953 commands it makes sense to initialize components of CPAN you need, e.g.:
11954
11955   CPAN::HandleConfig->load;
11956   CPAN::Shell::setup_output;
11957   CPAN::Index->reload;
11958
11959 High-level commands do such initializations automatically.
11960
11961 There's currently only one class that has a stable interface -
11962 CPAN::Shell. All commands that are available in the CPAN shell are
11963 methods of the class CPAN::Shell. Each of the commands that produce
11964 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11965 the IDs of all modules within the list.
11966
11967 =over 2
11968
11969 =item expand($type,@things)
11970
11971 The IDs of all objects available within a program are strings that can
11972 be expanded to the corresponding real objects with the
11973 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11974 list of CPAN::Module objects according to the C<@things> arguments
11975 given. In scalar context it only returns the first element of the
11976 list.
11977
11978 =item expandany(@things)
11979
11980 Like expand, but returns objects of the appropriate type, i.e.
11981 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11982 CPAN::Distribution objects for distributions. Note: it does not expand
11983 to CPAN::Author objects.
11984
11985 =item Programming Examples
11986
11987 This enables the programmer to do operations that combine
11988 functionalities that are available in the shell.
11989
11990     # install everything that is outdated on my disk:
11991     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11992
11993     # install my favorite programs if necessary:
11994     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11995         CPAN::Shell->install($mod);
11996     }
11997
11998     # list all modules on my disk that have no VERSION number
11999     for $mod (CPAN::Shell->expand("Module","/./")) {
12000         next unless $mod->inst_file;
12001         # MakeMaker convention for undefined $VERSION:
12002         next unless $mod->inst_version eq "undef";
12003         print "No VERSION in ", $mod->id, "\n";
12004     }
12005
12006     # find out which distribution on CPAN contains a module:
12007     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
12008
12009 Or if you want to write a cronjob to watch The CPAN, you could list
12010 all modules that need updating. First a quick and dirty way:
12011
12012     perl -e 'use CPAN; CPAN::Shell->r;'
12013
12014 If you don't want to get any output in the case that all modules are
12015 up to date, you can parse the output of above command for the regular
12016 expression //modules are up to date// and decide to mail the output
12017 only if it doesn't match. Ick?
12018
12019 If you prefer to do it more in a programmer style in one single
12020 process, maybe something like this suits you better:
12021
12022   # list all modules on my disk that have newer versions on CPAN
12023   for $mod (CPAN::Shell->expand("Module","/./")) {
12024     next unless $mod->inst_file;
12025     next if $mod->uptodate;
12026     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
12027         $mod->id, $mod->inst_version, $mod->cpan_version;
12028   }
12029
12030 If that gives you too much output every day, you maybe only want to
12031 watch for three modules. You can write
12032
12033   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
12034
12035 as the first line instead. Or you can combine some of the above
12036 tricks:
12037
12038   # watch only for a new mod_perl module
12039   $mod = CPAN::Shell->expand("Module","mod_perl");
12040   exit if $mod->uptodate;
12041   # new mod_perl arrived, let me know all update recommendations
12042   CPAN::Shell->r;
12043
12044 =back
12045
12046 =head2 Methods in the other Classes
12047
12048 =over 4
12049
12050 =item CPAN::Author::as_glimpse()
12051
12052 Returns a one-line description of the author
12053
12054 =item CPAN::Author::as_string()
12055
12056 Returns a multi-line description of the author
12057
12058 =item CPAN::Author::email()
12059
12060 Returns the author's email address
12061
12062 =item CPAN::Author::fullname()
12063
12064 Returns the author's name
12065
12066 =item CPAN::Author::name()
12067
12068 An alias for fullname
12069
12070 =item CPAN::Bundle::as_glimpse()
12071
12072 Returns a one-line description of the bundle
12073
12074 =item CPAN::Bundle::as_string()
12075
12076 Returns a multi-line description of the bundle
12077
12078 =item CPAN::Bundle::clean()
12079
12080 Recursively runs the C<clean> method on all items contained in the bundle.
12081
12082 =item CPAN::Bundle::contains()
12083
12084 Returns a list of objects' IDs contained in a bundle. The associated
12085 objects may be bundles, modules or distributions.
12086
12087 =item CPAN::Bundle::force($method,@args)
12088
12089 Forces CPAN to perform a task that it normally would have refused to
12090 do. Force takes as arguments a method name to be called and any number
12091 of additional arguments that should be passed to the called method.
12092 The internals of the object get the needed changes so that CPAN.pm
12093 does not refuse to take the action. The C<force> is passed recursively
12094 to all contained objects. See also the section above on the C<force>
12095 and the C<fforce> pragma.
12096
12097 =item CPAN::Bundle::get()
12098
12099 Recursively runs the C<get> method on all items contained in the bundle
12100
12101 =item CPAN::Bundle::inst_file()
12102
12103 Returns the highest installed version of the bundle in either @INC or
12104 C<$CPAN::Config->{cpan_home}>. Note that this is different from
12105 CPAN::Module::inst_file.
12106
12107 =item CPAN::Bundle::inst_version()
12108
12109 Like CPAN::Bundle::inst_file, but returns the $VERSION
12110
12111 =item CPAN::Bundle::uptodate()
12112
12113 Returns 1 if the bundle itself and all its members are uptodate.
12114
12115 =item CPAN::Bundle::install()
12116
12117 Recursively runs the C<install> method on all items contained in the bundle
12118
12119 =item CPAN::Bundle::make()
12120
12121 Recursively runs the C<make> method on all items contained in the bundle
12122
12123 =item CPAN::Bundle::readme()
12124
12125 Recursively runs the C<readme> method on all items contained in the bundle
12126
12127 =item CPAN::Bundle::test()
12128
12129 Recursively runs the C<test> method on all items contained in the bundle
12130
12131 =item CPAN::Distribution::as_glimpse()
12132
12133 Returns a one-line description of the distribution
12134
12135 =item CPAN::Distribution::as_string()
12136
12137 Returns a multi-line description of the distribution
12138
12139 =item CPAN::Distribution::author
12140
12141 Returns the CPAN::Author object of the maintainer who uploaded this
12142 distribution
12143
12144 =item CPAN::Distribution::pretty_id()
12145
12146 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
12147 author's PAUSE ID and TARBALL is the distribution filename.
12148
12149 =item CPAN::Distribution::base_id()
12150
12151 Returns the distribution filename without any archive suffix.  E.g
12152 "Foo-Bar-0.01"
12153
12154 =item CPAN::Distribution::clean()
12155
12156 Changes to the directory where the distribution has been unpacked and
12157 runs C<make clean> there.
12158
12159 =item CPAN::Distribution::containsmods()
12160
12161 Returns a list of IDs of modules contained in a distribution file.
12162 Only works for distributions listed in the 02packages.details.txt.gz
12163 file. This typically means that only the most recent version of a
12164 distribution is covered.
12165
12166 =item CPAN::Distribution::cvs_import()
12167
12168 Changes to the directory where the distribution has been unpacked and
12169 runs something like
12170
12171     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
12172
12173 there.
12174
12175 =item CPAN::Distribution::dir()
12176
12177 Returns the directory into which this distribution has been unpacked.
12178
12179 =item CPAN::Distribution::force($method,@args)
12180
12181 Forces CPAN to perform a task that it normally would have refused to
12182 do. Force takes as arguments a method name to be called and any number
12183 of additional arguments that should be passed to the called method.
12184 The internals of the object get the needed changes so that CPAN.pm
12185 does not refuse to take the action. See also the section above on the
12186 C<force> and the C<fforce> pragma.
12187
12188 =item CPAN::Distribution::get()
12189
12190 Downloads the distribution from CPAN and unpacks it. Does nothing if
12191 the distribution has already been downloaded and unpacked within the
12192 current session.
12193
12194 =item CPAN::Distribution::install()
12195
12196 Changes to the directory where the distribution has been unpacked and
12197 runs the external command C<make install> there. If C<make> has not
12198 yet been run, it will be run first. A C<make test> will be issued in
12199 any case and if this fails, the install will be canceled. The
12200 cancellation can be avoided by letting C<force> run the C<install> for
12201 you.
12202
12203 This install method has only the power to install the distribution if
12204 there are no dependencies in the way. To install an object and all of
12205 its dependencies, use CPAN::Shell->install.
12206
12207 Note that install() gives no meaningful return value. See uptodate().
12208
12209 =item CPAN::Distribution::install_tested()
12210
12211 Install all the distributions that have been tested sucessfully but
12212 not yet installed. See also C<is_tested>.
12213
12214 =item CPAN::Distribution::isa_perl()
12215
12216 Returns 1 if this distribution file seems to be a perl distribution.
12217 Normally this is derived from the file name only, but the index from
12218 CPAN can contain a hint to achieve a return value of true for other
12219 filenames too.
12220
12221 =item CPAN::Distribution::look()
12222
12223 Changes to the directory where the distribution has been unpacked and
12224 opens a subshell there. Exiting the subshell returns.
12225
12226 =item CPAN::Distribution::make()
12227
12228 First runs the C<get> method to make sure the distribution is
12229 downloaded and unpacked. Changes to the directory where the
12230 distribution has been unpacked and runs the external commands C<perl
12231 Makefile.PL> or C<perl Build.PL> and C<make> there.
12232
12233 =item CPAN::Distribution::perldoc()
12234
12235 Downloads the pod documentation of the file associated with a
12236 distribution (in html format) and runs it through the external
12237 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
12238 isn't available, it converts it to plain text with external
12239 command html2text and runs it through the pager specified
12240 in C<$CPAN::Config->{pager}>
12241
12242 =item CPAN::Distribution::prefs()
12243
12244 Returns the hash reference from the first matching YAML file that the
12245 user has deposited in the C<prefs_dir/> directory. The first
12246 succeeding match wins. The files in the C<prefs_dir/> are processed
12247 alphabetically and the canonical distroname (e.g.
12248 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
12249 stored in the $root->{match}{distribution} attribute value.
12250 Additionally all module names contained in a distribution are matched
12251 agains the regular expressions in the $root->{match}{module} attribute
12252 value. The two match values are ANDed together. Each of the two
12253 attributes are optional.
12254
12255 =item CPAN::Distribution::prereq_pm()
12256
12257 Returns the hash reference that has been announced by a distribution
12258 as the the C<requires> and C<build_requires> elements. These can be
12259 declared either by the C<META.yml> (if authoritative) or can be
12260 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
12261 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
12262 a comment in the produced C<Makefile>. I<Note>: this method only works
12263 after an attempt has been made to C<make> the distribution. Returns
12264 undef otherwise.
12265
12266 =item CPAN::Distribution::readme()
12267
12268 Downloads the README file associated with a distribution and runs it
12269 through the pager specified in C<$CPAN::Config->{pager}>.
12270
12271 =item CPAN::Distribution::reports()
12272
12273 Downloads report data for this distribution from cpantesters.perl.org
12274 and displays a subset of them.
12275
12276 =item CPAN::Distribution::read_yaml()
12277
12278 Returns the content of the META.yml of this distro as a hashref. Note:
12279 works only after an attempt has been made to C<make> the distribution.
12280 Returns undef otherwise. Also returns undef if the content of META.yml
12281 is not authoritative. (The rules about what exactly makes the content
12282 authoritative are still in flux.)
12283
12284 =item CPAN::Distribution::test()
12285
12286 Changes to the directory where the distribution has been unpacked and
12287 runs C<make test> there.
12288
12289 =item CPAN::Distribution::uptodate()
12290
12291 Returns 1 if all the modules contained in the distribution are
12292 uptodate. Relies on containsmods.
12293
12294 =item CPAN::Index::force_reload()
12295
12296 Forces a reload of all indices.
12297
12298 =item CPAN::Index::reload()
12299
12300 Reloads all indices if they have not been read for more than
12301 C<$CPAN::Config->{index_expire}> days.
12302
12303 =item CPAN::InfoObj::dump()
12304
12305 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
12306 inherit this method. It prints the data structure associated with an
12307 object. Useful for debugging. Note: the data structure is considered
12308 internal and thus subject to change without notice.
12309
12310 =item CPAN::Module::as_glimpse()
12311
12312 Returns a one-line description of the module in four columns: The
12313 first column contains the word C<Module>, the second column consists
12314 of one character: an equals sign if this module is already installed
12315 and uptodate, a less-than sign if this module is installed but can be
12316 upgraded, and a space if the module is not installed. The third column
12317 is the name of the module and the fourth column gives maintainer or
12318 distribution information.
12319
12320 =item CPAN::Module::as_string()
12321
12322 Returns a multi-line description of the module
12323
12324 =item CPAN::Module::clean()
12325
12326 Runs a clean on the distribution associated with this module.
12327
12328 =item CPAN::Module::cpan_file()
12329
12330 Returns the filename on CPAN that is associated with the module.
12331
12332 =item CPAN::Module::cpan_version()
12333
12334 Returns the latest version of this module available on CPAN.
12335
12336 =item CPAN::Module::cvs_import()
12337
12338 Runs a cvs_import on the distribution associated with this module.
12339
12340 =item CPAN::Module::description()
12341
12342 Returns a 44 character description of this module. Only available for
12343 modules listed in The Module List (CPAN/modules/00modlist.long.html
12344 or 00modlist.long.txt.gz)
12345
12346 =item CPAN::Module::distribution()
12347
12348 Returns the CPAN::Distribution object that contains the current
12349 version of this module.
12350
12351 =item CPAN::Module::dslip_status()
12352
12353 Returns a hash reference. The keys of the hash are the letters C<D>,
12354 C<S>, C<L>, C<I>, and <P>, for development status, support level,
12355 language, interface and public licence respectively. The data for the
12356 DSLIP status are collected by pause.perl.org when authors register
12357 their namespaces. The values of the 5 hash elements are one-character
12358 words whose meaning is described in the table below. There are also 5
12359 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
12360 verbose value of the 5 status variables.
12361
12362 Where the 'DSLIP' characters have the following meanings:
12363
12364   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
12365     i   - Idea, listed to gain consensus or as a placeholder
12366     c   - under construction but pre-alpha (not yet released)
12367     a/b - Alpha/Beta testing
12368     R   - Released
12369     M   - Mature (no rigorous definition)
12370     S   - Standard, supplied with Perl 5
12371
12372   S - Support Level:
12373     m   - Mailing-list
12374     d   - Developer
12375     u   - Usenet newsgroup comp.lang.perl.modules
12376     n   - None known, try comp.lang.perl.modules
12377     a   - abandoned; volunteers welcome to take over maintainance
12378
12379   L - Language Used:
12380     p   - Perl-only, no compiler needed, should be platform independent
12381     c   - C and perl, a C compiler will be needed
12382     h   - Hybrid, written in perl with optional C code, no compiler needed
12383     +   - C++ and perl, a C++ compiler will be needed
12384     o   - perl and another language other than C or C++
12385
12386   I - Interface Style
12387     f   - plain Functions, no references used
12388     h   - hybrid, object and function interfaces available
12389     n   - no interface at all (huh?)
12390     r   - some use of unblessed References or ties
12391     O   - Object oriented using blessed references and/or inheritance
12392
12393   P - Public License
12394     p   - Standard-Perl: user may choose between GPL and Artistic
12395     g   - GPL: GNU General Public License
12396     l   - LGPL: "GNU Lesser General Public License" (previously known as
12397           "GNU Library General Public License")
12398     b   - BSD: The BSD License
12399     a   - Artistic license alone
12400     2   - Artistic license 2.0 or later
12401     o   - open source: appoved by www.opensource.org
12402     d   - allows distribution without restrictions
12403     r   - restricted distribtion
12404     n   - no license at all
12405
12406 =item CPAN::Module::force($method,@args)
12407
12408 Forces CPAN to perform a task that it normally would have refused to
12409 do. Force takes as arguments a method name to be called and any number
12410 of additional arguments that should be passed to the called method.
12411 The internals of the object get the needed changes so that CPAN.pm
12412 does not refuse to take the action. See also the section above on the
12413 C<force> and the C<fforce> pragma.
12414
12415 =item CPAN::Module::get()
12416
12417 Runs a get on the distribution associated with this module.
12418
12419 =item CPAN::Module::inst_file()
12420
12421 Returns the filename of the module found in @INC. The first file found
12422 is reported just like perl itself stops searching @INC when it finds a
12423 module.
12424
12425 =item CPAN::Module::available_file()
12426
12427 Returns the filename of the module found in PERL5LIB or @INC. The
12428 first file found is reported. The advantage of this method over
12429 C<inst_file> is that modules that have been tested but not yet
12430 installed are included because PERL5LIB keeps track of tested modules.
12431
12432 =item CPAN::Module::inst_version()
12433
12434 Returns the version number of the installed module in readable format.
12435
12436 =item CPAN::Module::available_version()
12437
12438 Returns the version number of the available module in readable format.
12439
12440 =item CPAN::Module::install()
12441
12442 Runs an C<install> on the distribution associated with this module.
12443
12444 =item CPAN::Module::look()
12445
12446 Changes to the directory where the distribution associated with this
12447 module has been unpacked and opens a subshell there. Exiting the
12448 subshell returns.
12449
12450 =item CPAN::Module::make()
12451
12452 Runs a C<make> on the distribution associated with this module.
12453
12454 =item CPAN::Module::manpage_headline()
12455
12456 If module is installed, peeks into the module's manpage, reads the
12457 headline and returns it. Moreover, if the module has been downloaded
12458 within this session, does the equivalent on the downloaded module even
12459 if it is not installed.
12460
12461 =item CPAN::Module::perldoc()
12462
12463 Runs a C<perldoc> on this module.
12464
12465 =item CPAN::Module::readme()
12466
12467 Runs a C<readme> on the distribution associated with this module.
12468
12469 =item CPAN::Module::reports()
12470
12471 Calls the reports() method on the associated distribution object.
12472
12473 =item CPAN::Module::test()
12474
12475 Runs a C<test> on the distribution associated with this module.
12476
12477 =item CPAN::Module::uptodate()
12478
12479 Returns 1 if the module is installed and up-to-date.
12480
12481 =item CPAN::Module::userid()
12482
12483 Returns the author's ID of the module.
12484
12485 =back
12486
12487 =head2 Cache Manager
12488
12489 Currently the cache manager only keeps track of the build directory
12490 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
12491 deletes complete directories below C<build_dir> as soon as the size of
12492 all directories there gets bigger than $CPAN::Config->{build_cache}
12493 (in MB). The contents of this cache may be used for later
12494 re-installations that you intend to do manually, but will never be
12495 trusted by CPAN itself. This is due to the fact that the user might
12496 use these directories for building modules on different architectures.
12497
12498 There is another directory ($CPAN::Config->{keep_source_where}) where
12499 the original distribution files are kept. This directory is not
12500 covered by the cache manager and must be controlled by the user. If
12501 you choose to have the same directory as build_dir and as
12502 keep_source_where directory, then your sources will be deleted with
12503 the same fifo mechanism.
12504
12505 =head2 Bundles
12506
12507 A bundle is just a perl module in the namespace Bundle:: that does not
12508 define any functions or methods. It usually only contains documentation.
12509
12510 It starts like a perl module with a package declaration and a $VERSION
12511 variable. After that the pod section looks like any other pod with the
12512 only difference being that I<one special pod section> exists starting with
12513 (verbatim):
12514
12515     =head1 CONTENTS
12516
12517 In this pod section each line obeys the format
12518
12519         Module_Name [Version_String] [- optional text]
12520
12521 The only required part is the first field, the name of a module
12522 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
12523 of the line is optional. The comment part is delimited by a dash just
12524 as in the man page header.
12525
12526 The distribution of a bundle should follow the same convention as
12527 other distributions.
12528
12529 Bundles are treated specially in the CPAN package. If you say 'install
12530 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
12531 the modules in the CONTENTS section of the pod. You can install your
12532 own Bundles locally by placing a conformant Bundle file somewhere into
12533 your @INC path. The autobundle() command which is available in the
12534 shell interface does that for you by including all currently installed
12535 modules in a snapshot bundle file.
12536
12537 =head1 PREREQUISITES
12538
12539 If you have a local mirror of CPAN and can access all files with
12540 "file:" URLs, then you only need a perl better than perl5.003 to run
12541 this module. Otherwise Net::FTP is strongly recommended. LWP may be
12542 required for non-UNIX systems or if your nearest CPAN site is
12543 associated with a URL that is not C<ftp:>.
12544
12545 If you have neither Net::FTP nor LWP, there is a fallback mechanism
12546 implemented for an external ftp command or for an external lynx
12547 command.
12548
12549 =head1 UTILITIES
12550
12551 =head2 Finding packages and VERSION
12552
12553 This module presumes that all packages on CPAN
12554
12555 =over 2
12556
12557 =item *
12558
12559 declare their $VERSION variable in an easy to parse manner. This
12560 prerequisite can hardly be relaxed because it consumes far too much
12561 memory to load all packages into the running program just to determine
12562 the $VERSION variable. Currently all programs that are dealing with
12563 version use something like this
12564
12565     perl -MExtUtils::MakeMaker -le \
12566         'print MM->parse_version(shift)' filename
12567
12568 If you are author of a package and wonder if your $VERSION can be
12569 parsed, please try the above method.
12570
12571 =item *
12572
12573 come as compressed or gzipped tarfiles or as zip files and contain a
12574 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12575 without much enthusiasm).
12576
12577 =back
12578
12579 =head2 Debugging
12580
12581 The debugging of this module is a bit complex, because we have
12582 interferences of the software producing the indices on CPAN, of the
12583 mirroring process on CPAN, of packaging, of configuration, of
12584 synchronicity, and of bugs within CPAN.pm.
12585
12586 For debugging the code of CPAN.pm itself in interactive mode some more
12587 or less useful debugging aid can be turned on for most packages within
12588 CPAN.pm with one of
12589
12590 =over 2
12591
12592 =item o debug package...
12593
12594 sets debug mode for packages.
12595
12596 =item o debug -package...
12597
12598 unsets debug mode for packages.
12599
12600 =item o debug all
12601
12602 turns debugging on for all packages.
12603
12604 =item o debug number
12605
12606 =back
12607
12608 which sets the debugging packages directly. Note that C<o debug 0>
12609 turns debugging off.
12610
12611 What seems quite a successful strategy is the combination of C<reload
12612 cpan> and the debugging switches. Add a new debug statement while
12613 running in the shell and then issue a C<reload cpan> and see the new
12614 debugging messages immediately without losing the current context.
12615
12616 C<o debug> without an argument lists the valid package names and the
12617 current set of packages in debugging mode. C<o debug> has built-in
12618 completion support.
12619
12620 For debugging of CPAN data there is the C<dump> command which takes
12621 the same arguments as make/test/install and outputs each object's
12622 Data::Dumper dump. If an argument looks like a perl variable and
12623 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12624 Data::Dumper directly.
12625
12626 =head2 Floppy, Zip, Offline Mode
12627
12628 CPAN.pm works nicely without network too. If you maintain machines
12629 that are not networked at all, you should consider working with file:
12630 URLs. Of course, you have to collect your modules somewhere first. So
12631 you might use CPAN.pm to put together all you need on a networked
12632 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12633 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12634 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12635 with this floppy. See also below the paragraph about CD-ROM support.
12636
12637 =head2 Basic Utilities for Programmers
12638
12639 =over 2
12640
12641 =item has_inst($module)
12642
12643 Returns true if the module is installed. Used to load all modules into
12644 the running CPAN.pm which are considered optional. The config variable
12645 C<dontload_list> can be used to intercept the C<has_inst()> call such
12646 that an optional module is not loaded despite being available. For
12647 example the following command will prevent that C<YAML.pm> is being
12648 loaded:
12649
12650     cpan> o conf dontload_list push YAML
12651
12652 See the source for details.
12653
12654 =item has_usable($module)
12655
12656 Returns true if the module is installed and is in a usable state. Only
12657 useful for a handful of modules that are used internally. See the
12658 source for details.
12659
12660 =item instance($module)
12661
12662 The constructor for all the singletons used to represent modules,
12663 distributions, authors and bundles. If the object already exists, this
12664 method returns the object, otherwise it calls the constructor.
12665
12666 =back
12667
12668 =head1 SECURITY
12669
12670 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12671 install foreign, unmasked, unsigned code on your machine. We compare
12672 to a checksum that comes from the net just as the distribution file
12673 itself. But we try to make it easy to add security on demand:
12674
12675 =head2 Cryptographically signed modules
12676
12677 Since release 1.77 CPAN.pm has been able to verify cryptographically
12678 signed module distributions using Module::Signature.  The CPAN modules
12679 can be signed by their authors, thus giving more security.  The simple
12680 unsigned MD5 checksums that were used before by CPAN protect mainly
12681 against accidental file corruption.
12682
12683 You will need to have Module::Signature installed, which in turn
12684 requires that you have at least one of Crypt::OpenPGP module or the
12685 command-line F<gpg> tool installed.
12686
12687 You will also need to be able to connect over the Internet to the public
12688 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12689
12690 The configuration parameter check_sigs is there to turn signature
12691 checking on or off.
12692
12693 =head1 EXPORT
12694
12695 Most functions in package CPAN are exported per default. The reason
12696 for this is that the primary use is intended for the cpan shell or for
12697 one-liners.
12698
12699 =head1 ENVIRONMENT
12700
12701 When the CPAN shell enters a subshell via the look command, it sets
12702 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12703 already set.
12704
12705 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12706 to the ID of the running process. It also sets
12707 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12708 happen with older versions of Module::Install.
12709
12710 When running C<perl Makefile.PL>, the environment variable
12711 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12712 C<Makefile.PL> that is being executed. This prevents runaway processes
12713 with newer versions of Module::Install.
12714
12715 When the config variable ftp_passive is set, all downloads will be run
12716 with the environment variable FTP_PASSIVE set to this value. This is
12717 in general a good idea as it influences both Net::FTP and LWP based
12718 connections. The same effect can be achieved by starting the cpan
12719 shell with this environment variable set. For Net::FTP alone, one can
12720 also always set passive mode by running libnetcfg.
12721
12722 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12723
12724 Populating a freshly installed perl with my favorite modules is pretty
12725 easy if you maintain a private bundle definition file. To get a useful
12726 blueprint of a bundle definition file, the command autobundle can be used
12727 on the CPAN shell command line. This command writes a bundle definition
12728 file for all modules that are installed for the currently running perl
12729 interpreter. It's recommended to run this command only once and from then
12730 on maintain the file manually under a private name, say
12731 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12732
12733     cpan> install Bundle::my_bundle
12734
12735 then answer a few questions and then go out for a coffee.
12736
12737 Maintaining a bundle definition file means keeping track of two
12738 things: dependencies and interactivity. CPAN.pm sometimes fails on
12739 calculating dependencies because not all modules define all MakeMaker
12740 attributes correctly, so a bundle definition file should specify
12741 prerequisites as early as possible. On the other hand, it's a bit
12742 annoying that many distributions need some interactive configuring. So
12743 what I try to accomplish in my private bundle file is to have the
12744 packages that need to be configured early in the file and the gentle
12745 ones later, so I can go out after a few minutes and leave CPAN.pm
12746 untended.
12747
12748 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12749
12750 Thanks to Graham Barr for contributing the following paragraphs about
12751 the interaction between perl, and various firewall configurations. For
12752 further information on firewalls, it is recommended to consult the
12753 documentation that comes with the ncftp program. If you are unable to
12754 go through the firewall with a simple Perl setup, it is very likely
12755 that you can configure ncftp so that it works for your firewall.
12756
12757 =head2 Three basic types of firewalls
12758
12759 Firewalls can be categorized into three basic types.
12760
12761 =over 4
12762
12763 =item http firewall
12764
12765 This is where the firewall machine runs a web server and to access the
12766 outside world you must do it via the web server. If you set environment
12767 variables like http_proxy or ftp_proxy to a values beginning with http://
12768 or in your web browser you have to set proxy information then you know
12769 you are running an http firewall.
12770
12771 To access servers outside these types of firewalls with perl (even for
12772 ftp) you will need to use LWP.
12773
12774 =item ftp firewall
12775
12776 This where the firewall machine runs an ftp server. This kind of
12777 firewall will only let you access ftp servers outside the firewall.
12778 This is usually done by connecting to the firewall with ftp, then
12779 entering a username like "user@outside.host.com"
12780
12781 To access servers outside these type of firewalls with perl you
12782 will need to use Net::FTP.
12783
12784 =item One way visibility
12785
12786 I say one way visibility as these firewalls try to make themselves look
12787 invisible to the users inside the firewall. An FTP data connection is
12788 normally created by sending the remote server your IP address and then
12789 listening for the connection. But the remote server will not be able to
12790 connect to you because of the firewall. So for these types of firewall
12791 FTP connections need to be done in a passive mode.
12792
12793 There are two that I can think off.
12794
12795 =over 4
12796
12797 =item SOCKS
12798
12799 If you are using a SOCKS firewall you will need to compile perl and link
12800 it with the SOCKS library, this is what is normally called a 'socksified'
12801 perl. With this executable you will be able to connect to servers outside
12802 the firewall as if it is not there.
12803
12804 =item IP Masquerade
12805
12806 This is the firewall implemented in the Linux kernel, it allows you to
12807 hide a complete network behind one IP address. With this firewall no
12808 special compiling is needed as you can access hosts directly.
12809
12810 For accessing ftp servers behind such firewalls you usually need to
12811 set the environment variable C<FTP_PASSIVE> or the config variable
12812 ftp_passive to a true value.
12813
12814 =back
12815
12816 =back
12817
12818 =head2 Configuring lynx or ncftp for going through a firewall
12819
12820 If you can go through your firewall with e.g. lynx, presumably with a
12821 command such as
12822
12823     /usr/local/bin/lynx -pscott:tiger
12824
12825 then you would configure CPAN.pm with the command
12826
12827     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12828
12829 That's all. Similarly for ncftp or ftp, you would configure something
12830 like
12831
12832     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12833
12834 Your mileage may vary...
12835
12836 =head1 FAQ
12837
12838 =over 4
12839
12840 =item 1)
12841
12842 I installed a new version of module X but CPAN keeps saying,
12843 I have the old version installed
12844
12845 Most probably you B<do> have the old version installed. This can
12846 happen if a module installs itself into a different directory in the
12847 @INC path than it was previously installed. This is not really a
12848 CPAN.pm problem, you would have the same problem when installing the
12849 module manually. The easiest way to prevent this behaviour is to add
12850 the argument C<UNINST=1> to the C<make install> call, and that is why
12851 many people add this argument permanently by configuring
12852
12853   o conf make_install_arg UNINST=1
12854
12855 =item 2)
12856
12857 So why is UNINST=1 not the default?
12858
12859 Because there are people who have their precise expectations about who
12860 may install where in the @INC path and who uses which @INC array. In
12861 fine tuned environments C<UNINST=1> can cause damage.
12862
12863 =item 3)
12864
12865 I want to clean up my mess, and install a new perl along with
12866 all modules I have. How do I go about it?
12867
12868 Run the autobundle command for your old perl and optionally rename the
12869 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12870 with the Configure option prefix, e.g.
12871
12872     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12873
12874 Install the bundle file you produced in the first step with something like
12875
12876     cpan> install Bundle::mybundle
12877
12878 and you're done.
12879
12880 =item 4)
12881
12882 When I install bundles or multiple modules with one command
12883 there is too much output to keep track of.
12884
12885 You may want to configure something like
12886
12887   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12888   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12889
12890 so that STDOUT is captured in a file for later inspection.
12891
12892
12893 =item 5)
12894
12895 I am not root, how can I install a module in a personal directory?
12896
12897 First of all, you will want to use your own configuration, not the one
12898 that your root user installed. If you do not have permission to write
12899 in the cpan directory that root has configured, you will be asked if
12900 you want to create your own config. Answering "yes" will bring you into
12901 CPAN's configuration stage, using the system config for all defaults except
12902 things that have to do with CPAN's work directory, saving your choices to
12903 your MyConfig.pm file.
12904
12905 You can also manually initiate this process with the following command:
12906
12907     % perl -MCPAN -e 'mkmyconfig'
12908
12909 or by running
12910
12911     mkmyconfig
12912
12913 from the CPAN shell.
12914
12915 You will most probably also want to configure something like this:
12916
12917   o conf makepl_arg "LIB=~/myperl/lib \
12918                     INSTALLMAN1DIR=~/myperl/man/man1 \
12919                     INSTALLMAN3DIR=~/myperl/man/man3 \
12920                     INSTALLSCRIPT=~/myperl/bin \
12921                     INSTALLBIN=~/myperl/bin"
12922
12923 and then (oh joy) the equivalent command for Module::Build. That would
12924 be
12925
12926   o conf mbuildpl_arg "--lib=~/myperl/lib \
12927                     --installman1dir=~/myperl/man/man1 \
12928                     --installman3dir=~/myperl/man/man3 \
12929                     --installscript=~/myperl/bin \
12930                     --installbin=~/myperl/bin"
12931
12932 You can make this setting permanent like all C<o conf> settings with
12933 C<o conf commit> or by setting C<auto_commit> beforehand.
12934
12935 You will have to add ~/myperl/man to the MANPATH environment variable
12936 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12937 including
12938
12939   use lib "$ENV{HOME}/myperl/lib";
12940
12941 or setting the PERL5LIB environment variable.
12942
12943 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12944 that for Windows we use the File::HomeDir module that provides an
12945 equivalent to the concept of the home directory on Unix.
12946
12947 Another thing you should bear in mind is that the UNINST parameter can
12948 be dangerous when you are installing into a private area because you
12949 might accidentally remove modules that other people depend on that are
12950 not using the private area.
12951
12952 =item 6)
12953
12954 How to get a package, unwrap it, and make a change before building it?
12955
12956 Have a look at the C<look> (!) command.
12957
12958 =item 7)
12959
12960 I installed a Bundle and had a couple of fails. When I
12961 retried, everything resolved nicely. Can this be fixed to work
12962 on first try?
12963
12964 The reason for this is that CPAN does not know the dependencies of all
12965 modules when it starts out. To decide about the additional items to
12966 install, it just uses data found in the META.yml file or the generated
12967 Makefile. An undetected missing piece breaks the process. But it may
12968 well be that your Bundle installs some prerequisite later than some
12969 depending item and thus your second try is able to resolve everything.
12970 Please note, CPAN.pm does not know the dependency tree in advance and
12971 cannot sort the queue of things to install in a topologically correct
12972 order. It resolves perfectly well IF all modules declare the
12973 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12974 the C<requires> stanza of Module::Build. For bundles which fail and
12975 you need to install often, it is recommended to sort the Bundle
12976 definition file manually.
12977
12978 =item 8)
12979
12980 In our intranet we have many modules for internal use. How
12981 can I integrate these modules with CPAN.pm but without uploading
12982 the modules to CPAN?
12983
12984 Have a look at the CPAN::Site module.
12985
12986 =item 9)
12987
12988 When I run CPAN's shell, I get an error message about things in my
12989 /etc/inputrc (or ~/.inputrc) file.
12990
12991 These are readline issues and can only be fixed by studying readline
12992 configuration on your architecture and adjusting the referenced file
12993 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12994 and edit them. Quite often harmless changes like uppercasing or
12995 lowercasing some arguments solves the problem.
12996
12997 =item 10)
12998
12999 Some authors have strange characters in their names.
13000
13001 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
13002 expecting ISO-8859-1 charset, a converter can be activated by setting
13003 term_is_latin to a true value in your config file. One way of doing so
13004 would be
13005
13006     cpan> o conf term_is_latin 1
13007
13008 If other charset support is needed, please file a bugreport against
13009 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
13010 the support or maybe UTF-8 terminals become widely available.
13011
13012 Note: this config variable is deprecated and will be removed in a
13013 future version of CPAN.pm. It will be replaced with the conventions
13014 around the family of $LANG and $LC_* environment variables.
13015
13016 =item 11)
13017
13018 When an install fails for some reason and then I correct the error
13019 condition and retry, CPAN.pm refuses to install the module, saying
13020 C<Already tried without success>.
13021
13022 Use the force pragma like so
13023
13024   force install Foo::Bar
13025
13026 Or you can use
13027
13028   look Foo::Bar
13029
13030 and then 'make install' directly in the subshell.
13031
13032 =item 12)
13033
13034 How do I install a "DEVELOPER RELEASE" of a module?
13035
13036 By default, CPAN will install the latest non-developer release of a
13037 module. If you want to install a dev release, you have to specify the
13038 partial path starting with the author id to the tarball you wish to
13039 install, like so:
13040
13041     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
13042
13043 Note that you can use the C<ls> command to get this path listed.
13044
13045 =item 13)
13046
13047 How do I install a module and all its dependencies from the commandline,
13048 without being prompted for anything, despite my CPAN configuration
13049 (or lack thereof)?
13050
13051 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
13052 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
13053 asked any questions at all (assuming the modules you are installing are
13054 nice about obeying that variable as well):
13055
13056     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
13057
13058 =item 14)
13059
13060 How do I create a Module::Build based Build.PL derived from an
13061 ExtUtils::MakeMaker focused Makefile.PL?
13062
13063 http://search.cpan.org/search?query=Module::Build::Convert
13064
13065 http://www.refcnt.org/papers/module-build-convert
13066
13067 =item 15)
13068
13069 I'm frequently irritated with the CPAN shell's inability to help me
13070 select a good mirror.
13071
13072 The urllist config parameter is yours. You can add and remove sites at
13073 will. You should find out which sites have the best uptodateness,
13074 bandwidth, reliability, etc. and are topologically close to you. Some
13075 people prefer fast downloads, others uptodateness, others reliability.
13076 You decide which to try in which order.
13077
13078 Henk P. Penning maintains a site that collects data about CPAN sites:
13079
13080   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
13081
13082 Also, feel free to play with experimental features. Run
13083
13084   o conf init randomize_urllist ftpstats_period ftpstats_size
13085
13086 and choose your favorite parameters. After a few downloads running the
13087 C<hosts> command will probably assist you in choosing the best mirror
13088 sites.
13089
13090 =item 16)
13091
13092 Why do I get asked the same questions every time I start the shell?
13093
13094 You can make your configuration changes permanent by calling the
13095 command C<o conf commit>. Alternatively set the C<auto_commit>
13096 variable to true by running C<o conf init auto_commit> and answering
13097 the following question with yes.
13098
13099 =item 17)
13100
13101 Older versions of CPAN.pm had the original root directory of all
13102 tarballs in the build directory. Now there are always random
13103 characters appended to these directory names. Why was this done?
13104
13105 The random characters are provided by File::Temp and ensure that each
13106 module's individual build directory is unique. This makes running
13107 CPAN.pm in concurrent processes simultaneously safe.
13108
13109 =item 18)
13110
13111 Speaking of the build directory. Do I have to clean it up myself?
13112
13113 You have the choice to set the config variable C<scan_cache> to
13114 C<never>. Then you must clean it up yourself. The other possible
13115 value, C<atstart> only cleans up the build directory when you start
13116 the CPAN shell. If you never start up the CPAN shell, you probably
13117 also have to clean up the build directory yourself.
13118
13119 =back
13120
13121 =head1 COMPATIBILITY
13122
13123 =head2 OLD PERL VERSIONS
13124
13125 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
13126 newer versions. It is getting more and more difficult to get the
13127 minimal prerequisites working on older perls. It is close to
13128 impossible to get the whole Bundle::CPAN working there. If you're in
13129 the position to have only these old versions, be advised that CPAN is
13130 designed to work fine without the Bundle::CPAN installed.
13131
13132 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
13133 compatible with ancient perls and that File::Temp is listed as a
13134 prerequisite but CPAN has reasonable workarounds if it is missing.
13135
13136 =head2 CPANPLUS
13137
13138 This module and its competitor, the CPANPLUS module, are both much
13139 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
13140 more modular but it was never tried to make it compatible with CPAN.pm.
13141
13142 =head1 SECURITY ADVICE
13143
13144 This software enables you to upgrade software on your computer and so
13145 is inherently dangerous because the newly installed software may
13146 contain bugs and may alter the way your computer works or even make it
13147 unusable. Please consider backing up your data before every upgrade.
13148
13149 =head1 BUGS
13150
13151 Please report bugs via L<http://rt.cpan.org/>
13152
13153 Before submitting a bug, please make sure that the traditional method
13154 of building a Perl module package from a shell by following the
13155 installation instructions of that package still works in your
13156 environment.
13157
13158 =head1 AUTHOR
13159
13160 Andreas Koenig C<< <andk@cpan.org> >>
13161
13162 =head1 LICENSE
13163
13164 This program is free software; you can redistribute it and/or
13165 modify it under the same terms as Perl itself.
13166
13167 See L<http://www.perl.com/perl/misc/Artistic.html>
13168
13169 =head1 TRANSLATIONS
13170
13171 Kawai,Takanori provides a Japanese translation of this manpage at
13172 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
13173
13174 =head1 SEE ALSO
13175
13176 L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
13177
13178 =cut
13179
13180