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.93_03'; # make the _03 a dev release and release it as 1.9304 after merge into blead
   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 => "write 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          get => "download a distribution",
 938          h => \"help",
 939          help => "overview over commands; 'help ...' explains specific commands",
 940          hosts => "statistics about recently used hosts",
 941          i => "info about authors/bundles/distributions/modules",
 942          install => "install a distribution",
 943          install_tested => "install all distributions tested OK",
 944          is_tested => "list all distributions tested OK",
 945          look => "open a subshell in a distribution's directory",
 946          ls => "list distributions according to a glob",
 947          m => "info about a module",
 948          make => "make/build a distribution",
 949          mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 950          notest => "run a (usually install) command but leave out the test phase",
 951          o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 952          perldoc => "try to get a manpage for a module",
 953          q => \"quit",
 954          quit => "leave the cpan shell",
 955          r => "review over upgradeable modules",
 956          readme => "display the README of a distro with a pager",
 957          recent => "show recent uploads to the CPAN",
 958          # recompile
 959          reload => "'reload cpan' or 'reload index'",
 960          report => "test a distribution and send a test report to cpantesters",
 961          reports => "info about reported tests from cpantesters",
 962          # scripts
 963          # smoke
 964          test => "test a distribution",
 965          u => "display uninstalled modules",
 966          upgrade => "combine 'r' command with immediate installation",
 967         };
 968 {
 969     $autoload_recursion   ||= 0;
 970
 971     #-> sub CPAN::Shell::AUTOLOAD ;
 972     sub AUTOLOAD {
 973         $autoload_recursion++;
 974         my($l) = $AUTOLOAD;
 975         my $class = shift(@_);
 976         # warn "autoload[$l] class[$class]";
 977         $l =~ s/.*:://;
 978         if ($CPAN::Signal) {
 979             warn "Refusing to autoload '$l' while signal pending";
 980             $autoload_recursion--;
 981             return;
 982         }
 983         if ($autoload_recursion > 1) {
 984             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 985             warn "Refusing to autoload $fullcommand in recursion\n";
 986             $autoload_recursion--;
 987             return;
 988         }
 989         if ($l =~ /^w/) {
 990             # XXX needs to be reconsidered
 991             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 992                 CPAN::WAIT->$l(@_);
 993             } else {
 994                 $CPAN::Frontend->mywarn(qq{
 995 Commands starting with "w" require CPAN::WAIT to be installed.
 996 Please consider installing CPAN::WAIT to use the fulltext index.
 997 For this you just need to type
 998     install CPAN::WAIT
 999 });
1000             }
1001         } else {
1002             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
1003                                     qq{Type ? for help.
1004 });
1005         }
1006         $autoload_recursion--;
1007     }
1008 }
1009
1010 package CPAN;
1011 use strict;
1012
1013 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
1014
1015 # from here on only subs.
1016 ################################################################################
1017
1018 sub _perl_fingerprint {
1019     my($self,$other_fingerprint) = @_;
1020     my $dll = eval {OS2::DLLname()};
1021     my $mtime_dll = 0;
1022     if (defined $dll) {
1023         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
1024     }
1025     my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
1026     my $this_fingerprint = {
1027                             '$^X' => CPAN::find_perl,
1028                             sitearchexp => $Config::Config{sitearchexp},
1029                             'mtime_$^X' => $mtime_perl,
1030                             'mtime_dll' => $mtime_dll,
1031                            };
1032     if ($other_fingerprint) {
1033         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
1034             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
1035         }
1036         # mandatory keys since 1.88_57
1037         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
1038             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
1039         }
1040         return 1;
1041     } else {
1042         return $this_fingerprint;
1043     }
1044 }
1045
1046 sub suggest_myconfig () {
1047   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
1048         $CPAN::Frontend->myprint("You don't seem to have a user ".
1049                                  "configuration (MyConfig.pm) yet.\n");
1050         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
1051                                               "user configuration now? (Y/n)",
1052                                               "yes");
1053         if($new =~ m{^y}i) {
1054             CPAN::Shell->mkmyconfig();
1055             return &checklock;
1056         } else {
1057             $CPAN::Frontend->mydie("OK, giving up.");
1058         }
1059     }
1060 }
1061
1062 #-> sub CPAN::all_objects ;
1063 sub all_objects {
1064     my($mgr,$class) = @_;
1065     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1066     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
1067     CPAN::Index->reload;
1068     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
1069 }
1070
1071 # Called by shell, not in batch mode. In batch mode I see no risk in
1072 # having many processes updating something as installations are
1073 # continually checked at runtime. In shell mode I suspect it is
1074 # unintentional to open more than one shell at a time
1075
1076 #-> sub CPAN::checklock ;
1077 sub checklock {
1078     my($self) = @_;
1079     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
1080     if (-f $lockfile && -M _ > 0) {
1081         my $fh = FileHandle->new($lockfile) or
1082             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
1083         my $otherpid  = <$fh>;
1084         my $otherhost = <$fh>;
1085         $fh->close;
1086         if (defined $otherpid && $otherpid) {
1087             chomp $otherpid;
1088         }
1089         if (defined $otherhost && $otherhost) {
1090             chomp $otherhost;
1091         }
1092         my $thishost  = hostname();
1093         if (defined $otherhost && defined $thishost &&
1094             $otherhost ne '' && $thishost ne '' &&
1095             $otherhost ne $thishost) {
1096             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
1097                                            "reports other host $otherhost and other ".
1098                                            "process $otherpid.\n".
1099                                            "Cannot proceed.\n"));
1100         } elsif ($RUN_DEGRADED) {
1101             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
1102         } elsif (defined $otherpid && $otherpid) {
1103             return if $$ == $otherpid; # should never happen
1104             $CPAN::Frontend->mywarn(
1105                                     qq{
1106 There seems to be running another CPAN process (pid $otherpid).  Contacting...
1107 });
1108             if (kill 0, $otherpid or $!{EPERM}) {
1109                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1110                 my($ans) =
1111                     CPAN::Shell::colorable_makemaker_prompt
1112                         (qq{Shall I try to run in degraded }.
1113                         qq{mode? (Y/n)},"y");
1114                 if ($ans =~ /^y/i) {
1115                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1116 Please report if something unexpected happens\n");
1117                     $RUN_DEGRADED = 1;
1118                     for ($CPAN::Config) {
1119                         # XXX
1120                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1121                         $_->{commandnumber_in_prompt} = 0; # visibility
1122                         $_->{histfile}       = "";  # who should win otherwise?
1123                         $_->{cache_metadata} = 0;   # better would be a lock?
1124                         $_->{use_sqlite}     = 0;   # better would be a write lock!
1125                         $_->{auto_commit}    = 0;   # we are violent, do not persist
1126                         $_->{test_report}    = 0;   # Oliver Paukstadt had sent wrong reports in degraded mode
1127                     }
1128                 } else {
1129                     $CPAN::Frontend->mydie("
1130 You may want to kill the other job and delete the lockfile. On UNIX try:
1131     kill $otherpid
1132     rm $lockfile
1133 ");
1134                 }
1135             } elsif (-w $lockfile) {
1136                 my($ans) =
1137                     CPAN::Shell::colorable_makemaker_prompt
1138                         (qq{Other job not responding. Shall I overwrite }.
1139                         qq{the lockfile '$lockfile'? (Y/n)},"y");
1140             $CPAN::Frontend->myexit("Ok, bye\n")
1141                 unless $ans =~ /^y/i;
1142             } else {
1143                 Carp::croak(
1144                     qq{Lockfile '$lockfile' not writeable by you. }.
1145                     qq{Cannot proceed.\n}.
1146                     qq{    On UNIX try:\n}.
1147                     qq{    rm '$lockfile'\n}.
1148                     qq{  and then rerun us.\n}
1149                 );
1150             }
1151         } else {
1152             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1153                                            "'$lockfile', please remove. Cannot proceed.\n"));
1154         }
1155     }
1156     my $dotcpan = $CPAN::Config->{cpan_home};
1157     eval { File::Path::mkpath($dotcpan);};
1158     if ($@) {
1159         # A special case at least for Jarkko.
1160         my $firsterror = $@;
1161         my $seconderror;
1162         my $symlinkcpan;
1163         if (-l $dotcpan) {
1164             $symlinkcpan = readlink $dotcpan;
1165             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1166             eval { File::Path::mkpath($symlinkcpan); };
1167             if ($@) {
1168                 $seconderror = $@;
1169             } else {
1170                 $CPAN::Frontend->mywarn(qq{
1171 Working directory $symlinkcpan created.
1172 });
1173             }
1174         }
1175         unless (-d $dotcpan) {
1176             my $mess = qq{
1177 Your configuration suggests "$dotcpan" as your
1178 CPAN.pm working directory. I could not create this directory due
1179 to this error: $firsterror\n};
1180             $mess .= qq{
1181 As "$dotcpan" is a symlink to "$symlinkcpan",
1182 I tried to create that, but I failed with this error: $seconderror
1183 } if $seconderror;
1184             $mess .= qq{
1185 Please make sure the directory exists and is writable.
1186 };
1187             $CPAN::Frontend->mywarn($mess);
1188             return suggest_myconfig;
1189         }
1190     } # $@ after eval mkpath $dotcpan
1191     if (0) { # to test what happens when a race condition occurs
1192         for (reverse 1..10) {
1193             print $_, "\n";
1194             sleep 1;
1195         }
1196     }
1197     # locking
1198     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1199         my $fh;
1200         unless ($fh = FileHandle->new("+>>$lockfile")) {
1201             if ($! =~ /Permission/) {
1202                 $CPAN::Frontend->mywarn(qq{
1203
1204 Your configuration suggests that CPAN.pm should use a working
1205 directory of
1206     $CPAN::Config->{cpan_home}
1207 Unfortunately we could not create the lock file
1208     $lockfile
1209 due to permission problems.
1210
1211 Please make sure that the configuration variable
1212     \$CPAN::Config->{cpan_home}
1213 points to a directory where you can write a .lock file. You can set
1214 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1215 \@INC path;
1216 });
1217                 return suggest_myconfig;
1218             }
1219         }
1220         my $sleep = 1;
1221         while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1222             if ($sleep>10) {
1223                 $CPAN::Frontend->mydie("Giving up\n");
1224             }
1225             $CPAN::Frontend->mysleep($sleep++);
1226             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1227         }
1228
1229         seek $fh, 0, 0;
1230         truncate $fh, 0;
1231         $fh->autoflush(1);
1232         $fh->print($$, "\n");
1233         $fh->print(hostname(), "\n");
1234         $self->{LOCK} = $lockfile;
1235         $self->{LOCKFH} = $fh;
1236     }
1237     $SIG{TERM} = sub {
1238         my $sig = shift;
1239         &cleanup;
1240         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1241     };
1242     $SIG{INT} = sub {
1243       # no blocks!!!
1244         my $sig = shift;
1245         &cleanup if $Signal;
1246         die "Got yet another signal" if $Signal > 1;
1247         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1248         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1249         $Signal++;
1250     };
1251
1252 #       From: Larry Wall <larry@wall.org>
1253 #       Subject: Re: deprecating SIGDIE
1254 #       To: perl5-porters@perl.org
1255 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1256 #
1257 #       The original intent of __DIE__ was only to allow you to substitute one
1258 #       kind of death for another on an application-wide basis without respect
1259 #       to whether you were in an eval or not.  As a global backstop, it should
1260 #       not be used any more lightly (or any more heavily :-) than class
1261 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1262 #       be politely squashed.  Any bug that causes every eval {} to have to be
1263 #       modified should be not so politely squashed.
1264 #
1265 #       Those are my current opinions.  It is also my optinion that polite
1266 #       arguments degenerate to personal arguments far too frequently, and that
1267 #       when they do, it's because both people wanted it to, or at least didn't
1268 #       sufficiently want it not to.
1269 #
1270 #       Larry
1271
1272     # global backstop to cleanup if we should really die
1273     $SIG{__DIE__} = \&cleanup;
1274     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1275 }
1276
1277 #-> sub CPAN::DESTROY ;
1278 sub DESTROY {
1279     &cleanup; # need an eval?
1280 }
1281
1282 #-> sub CPAN::anycwd ;
1283 sub anycwd () {
1284     my $getcwd;
1285     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1286     CPAN->$getcwd();
1287 }
1288
1289 #-> sub CPAN::cwd ;
1290 sub cwd {Cwd::cwd();}
1291
1292 #-> sub CPAN::getcwd ;
1293 sub getcwd {Cwd::getcwd();}
1294
1295 #-> sub CPAN::fastcwd ;
1296 sub fastcwd {Cwd::fastcwd();}
1297
1298 #-> sub CPAN::backtickcwd ;
1299 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1300
1301 #-> sub CPAN::find_perl ;
1302 sub find_perl () {
1303     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1304     unless ($perl) {
1305         my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
1306         $^X = $perl = $candidate if MM->maybe_command($candidate);
1307     }
1308     unless ($perl) {
1309         my ($component,$perl_name);
1310       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1311           PATH_COMPONENT: foreach $component (File::Spec->path(),
1312                                                 $Config::Config{'binexp'}) {
1313                 next unless defined($component) && $component;
1314                 my($abs) = File::Spec->catfile($component,$perl_name);
1315                 if (MM->maybe_command($abs)) {
1316                     $^X = $perl = $abs;
1317                     last DIST_PERLNAME;
1318                 }
1319             }
1320         }
1321     }
1322     return $perl;
1323 }
1324
1325
1326 #-> sub CPAN::exists ;
1327 sub exists {
1328     my($mgr,$class,$id) = @_;
1329     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1330     CPAN::Index->reload;
1331     ### Carp::croak "exists called without class argument" unless $class;
1332     $id ||= "";
1333     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1334     my $exists;
1335     if (CPAN::_sqlite_running) {
1336         $exists = (exists $META->{readonly}{$class}{$id} or
1337                    $CPAN::SQLite->set($class, $id));
1338     } else {
1339         $exists =  exists $META->{readonly}{$class}{$id};
1340     }
1341     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1342 }
1343
1344 #-> sub CPAN::delete ;
1345 sub delete {
1346   my($mgr,$class,$id) = @_;
1347   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1348   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1349 }
1350
1351 #-> sub CPAN::has_usable
1352 # has_inst is sometimes too optimistic, we should replace it with this
1353 # has_usable whenever a case is given
1354 sub has_usable {
1355     my($self,$mod,$message) = @_;
1356     return 1 if $HAS_USABLE->{$mod};
1357     my $has_inst = $self->has_inst($mod,$message);
1358     return unless $has_inst;
1359     my $usable;
1360     $usable = {
1361                LWP => [ # we frequently had "Can't locate object
1362                         # method "new" via package "LWP::UserAgent" at
1363                         # (eval 69) line 2006
1364                        sub {require LWP},
1365                        sub {require LWP::UserAgent},
1366                        sub {require HTTP::Request},
1367                        sub {require URI::URL},
1368                       ],
1369                'Net::FTP' => [
1370                             sub {require Net::FTP},
1371                             sub {require Net::Config},
1372                            ],
1373                'File::HomeDir' => [
1374                                    sub {require File::HomeDir;
1375                                         unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1376                                             for ("Will not use File::HomeDir, need 0.52\n") {
1377                                                 $CPAN::Frontend->mywarn($_);
1378                                                 die $_;
1379                                             }
1380                                         }
1381                                     },
1382                                   ],
1383                'Archive::Tar' => [
1384                                   sub {require Archive::Tar;
1385                                        unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1386                                             for ("Will not use Archive::Tar, need 1.00\n") {
1387                                                 $CPAN::Frontend->mywarn($_);
1388                                                 die $_;
1389                                             }
1390                                        }
1391                                   },
1392                                  ],
1393                'File::Temp' => [
1394                                 # XXX we should probably delete from
1395                                 # %INC too so we can load after we
1396                                 # installed a new enough version --
1397                                 # I'm not sure.
1398                                 sub {require File::Temp;
1399                                      unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1400                                          for ("Will not use File::Temp, need 0.16\n") {
1401                                                 $CPAN::Frontend->mywarn($_);
1402                                                 die $_;
1403                                          }
1404                                      }
1405                                 },
1406                                ]
1407               };
1408     if ($usable->{$mod}) {
1409         for my $c (0..$#{$usable->{$mod}}) {
1410             my $code = $usable->{$mod}[$c];
1411             my $ret = eval { &$code() };
1412             $ret = "" unless defined $ret;
1413             if ($@) {
1414                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1415                 return;
1416             }
1417         }
1418     }
1419     return $HAS_USABLE->{$mod} = 1;
1420 }
1421
1422 #-> sub CPAN::has_inst
1423 sub has_inst {
1424     my($self,$mod,$message) = @_;
1425     Carp::croak("CPAN->has_inst() called without an argument")
1426         unless defined $mod;
1427     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1428         keys %{$CPAN::Config->{dontload_hash}||{}},
1429             @{$CPAN::Config->{dontload_list}||[]};
1430     if (defined $message && $message eq "no"  # afair only used by Nox
1431         ||
1432         $dont{$mod}
1433        ) {
1434       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1435       return 0;
1436     }
1437     my $file = $mod;
1438     my $obj;
1439     $file =~ s|::|/|g;
1440     $file .= ".pm";
1441     if ($INC{$file}) {
1442         # checking %INC is wrong, because $INC{LWP} may be true
1443         # although $INC{"URI/URL.pm"} may have failed. But as
1444         # I really want to say "bla loaded OK", I have to somehow
1445         # cache results.
1446         ### warn "$file in %INC"; #debug
1447         return 1;
1448     } elsif (eval { require $file }) {
1449         # eval is good: if we haven't yet read the database it's
1450         # perfect and if we have installed the module in the meantime,
1451         # it tries again. The second require is only a NOOP returning
1452         # 1 if we had success, otherwise it's retrying
1453
1454         my $mtime = (stat $INC{$file})[9];
1455         # privileged files loaded by has_inst; Note: we use $mtime
1456         # as a proxy for a checksum.
1457         $CPAN::Shell::reload->{$file} = $mtime;
1458         my $v = eval "\$$mod\::VERSION";
1459         $v = $v ? " (v$v)" : "";
1460         CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1461         if ($mod eq "CPAN::WAIT") {
1462             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1463         }
1464         return 1;
1465     } elsif ($mod eq "Net::FTP") {
1466         $CPAN::Frontend->mywarn(qq{
1467   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1468   if you just type
1469       install Bundle::libnet
1470
1471 }) unless $Have_warned->{"Net::FTP"}++;
1472         $CPAN::Frontend->mysleep(3);
1473     } elsif ($mod eq "Digest::SHA") {
1474         if ($Have_warned->{"Digest::SHA"}++) {
1475             $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1476                                      qq{because Digest::SHA not installed.\n});
1477         } else {
1478             $CPAN::Frontend->mywarn(qq{
1479   CPAN: checksum security checks disabled because Digest::SHA not installed.
1480   Please consider installing the Digest::SHA module.
1481
1482 });
1483             $CPAN::Frontend->mysleep(2);
1484         }
1485     } elsif ($mod eq "Module::Signature") {
1486         # NOT prefs_lookup, we are not a distro
1487         my $check_sigs = $CPAN::Config->{check_sigs};
1488         if (not $check_sigs) {
1489             # they do not want us:-(
1490         } elsif (not $Have_warned->{"Module::Signature"}++) {
1491             # No point in complaining unless the user can
1492             # reasonably install and use it.
1493             if (eval { require Crypt::OpenPGP; 1 } ||
1494                 (
1495                  defined $CPAN::Config->{'gpg'}
1496                  &&
1497                  $CPAN::Config->{'gpg'} =~ /\S/
1498                 )
1499                ) {
1500                 $CPAN::Frontend->mywarn(qq{
1501   CPAN: Module::Signature security checks disabled because Module::Signature
1502   not installed.  Please consider installing the Module::Signature module.
1503   You may also need to be able to connect over the Internet to the public
1504   keyservers like pgp.mit.edu (port 11371).
1505
1506 });
1507                 $CPAN::Frontend->mysleep(2);
1508             }
1509         }
1510     } else {
1511         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1512     }
1513     return 0;
1514 }
1515
1516 #-> sub CPAN::instance ;
1517 sub instance {
1518     my($mgr,$class,$id) = @_;
1519     CPAN::Index->reload;
1520     $id ||= "";
1521     # unsafe meta access, ok?
1522     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1523     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1524 }
1525
1526 #-> sub CPAN::new ;
1527 sub new {
1528     bless {}, shift;
1529 }
1530
1531 #-> sub CPAN::cleanup ;
1532 sub cleanup {
1533   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1534   local $SIG{__DIE__} = '';
1535   my($message) = @_;
1536   my $i = 0;
1537   my $ineval = 0;
1538   my($subroutine);
1539   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1540       $ineval = 1, last if
1541         $subroutine eq '(eval)';
1542   }
1543   return if $ineval && !$CPAN::End;
1544   return unless defined $META->{LOCK};
1545   return unless -f $META->{LOCK};
1546   $META->savehist;
1547   close $META->{LOCKFH};
1548   unlink $META->{LOCK};
1549   # require Carp;
1550   # Carp::cluck("DEBUGGING");
1551   if ( $CPAN::CONFIG_DIRTY ) {
1552       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1553   }
1554   $CPAN::Frontend->myprint("Lockfile removed.\n");
1555 }
1556
1557 #-> sub CPAN::readhist
1558 sub readhist {
1559     my($self,$term,$histfile) = @_;
1560     my $histsize = $CPAN::Config->{'histsize'} || 100;
1561     $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1562     my($fh) = FileHandle->new;
1563     open $fh, "<$histfile" or return;
1564     local $/ = "\n";
1565     while (<$fh>) {
1566         chomp;
1567         $term->AddHistory($_);
1568     }
1569     close $fh;
1570 }
1571
1572 #-> sub CPAN::savehist
1573 sub savehist {
1574     my($self) = @_;
1575     my($histfile,$histsize);
1576     unless ($histfile = $CPAN::Config->{'histfile'}) {
1577         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1578         return;
1579     }
1580     $histsize = $CPAN::Config->{'histsize'} || 100;
1581     if ($CPAN::term) {
1582         unless ($CPAN::term->can("GetHistory")) {
1583             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1584             return;
1585         }
1586     } else {
1587         return;
1588     }
1589     my @h = $CPAN::term->GetHistory;
1590     splice @h, 0, @h-$histsize if @h>$histsize;
1591     my($fh) = FileHandle->new;
1592     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1593     local $\ = local $, = "\n";
1594     print $fh @h;
1595     close $fh;
1596 }
1597
1598 #-> sub CPAN::is_tested
1599 sub is_tested {
1600     my($self,$what,$when) = @_;
1601     unless ($what) {
1602         Carp::cluck("DEBUG: empty what");
1603         return;
1604     }
1605     $self->{is_tested}{$what} = $when;
1606 }
1607
1608 #-> sub CPAN::reset_tested
1609 # forget all distributions tested -- resets what gets included in PERL5LIB
1610 sub reset_tested {
1611     my ($self) = @_;
1612     $self->{is_tested} = {};
1613 }
1614
1615 #-> sub CPAN::is_installed
1616 # unsets the is_tested flag: as soon as the thing is installed, it is
1617 # not needed in set_perl5lib anymore
1618 sub is_installed {
1619     my($self,$what) = @_;
1620     delete $self->{is_tested}{$what};
1621 }
1622
1623 sub _list_sorted_descending_is_tested {
1624     my($self) = @_;
1625     sort
1626         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1627             keys %{$self->{is_tested}}
1628 }
1629
1630 #-> sub CPAN::set_perl5lib
1631 # Notes on max environment variable length:
1632 #   - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1633 {
1634 my $fh;
1635 sub set_perl5lib {
1636     my($self,$for) = @_;
1637     unless ($for) {
1638         (undef,undef,undef,$for) = caller(1);
1639         $for =~ s/.*://;
1640     }
1641     $self->{is_tested} ||= {};
1642     return unless %{$self->{is_tested}};
1643     my $env = $ENV{PERL5LIB};
1644     $env = $ENV{PERLLIB} unless defined $env;
1645     my @env;
1646     push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1647     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1648     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1649
1650     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1651     return if !@dirs;
1652
1653     if (@dirs < 12) {
1654         $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1655         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1656     } elsif (@dirs < 24 ) {
1657         my @d = map {my $cp = $_;
1658                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1659                      $cp
1660                  } @dirs;
1661         $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1662                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1663                                  "for '$for'\n"
1664                                 );
1665         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1666     } else {
1667         my $cnt = keys %{$self->{is_tested}};
1668         $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
1669                                  "$cnt build dirs to PERL5LIB; ".
1670                                  "for '$for'\n"
1671                                 );
1672         $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1673     }
1674 }}
1675
1676 package CPAN::CacheMgr;
1677 use strict;
1678
1679 #-> sub CPAN::CacheMgr::as_string ;
1680 sub as_string {
1681     eval { require Data::Dumper };
1682     if ($@) {
1683         return shift->SUPER::as_string;
1684     } else {
1685         return Data::Dumper::Dumper(shift);
1686     }
1687 }
1688
1689 #-> sub CPAN::CacheMgr::cachesize ;
1690 sub cachesize {
1691     shift->{DU};
1692 }
1693
1694 #-> sub CPAN::CacheMgr::tidyup ;
1695 sub tidyup {
1696   my($self) = @_;
1697   return unless $CPAN::META->{LOCK};
1698   return unless -d $self->{ID};
1699   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1700   for my $current (0..$#toremove) {
1701     my $toremove = $toremove[$current];
1702     $CPAN::Frontend->myprint(sprintf(
1703                                      "DEL(%d/%d): %s \n",
1704                                      $current+1,
1705                                      scalar @toremove,
1706                                      $toremove,
1707                                     )
1708                             );
1709     return if $CPAN::Signal;
1710     $self->_clean_cache($toremove);
1711     return if $CPAN::Signal;
1712   }
1713 }
1714
1715 #-> sub CPAN::CacheMgr::dir ;
1716 sub dir {
1717     shift->{ID};
1718 }
1719
1720 #-> sub CPAN::CacheMgr::entries ;
1721 sub entries {
1722     my($self,$dir) = @_;
1723     return unless defined $dir;
1724     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1725     $dir ||= $self->{ID};
1726     my($cwd) = CPAN::anycwd();
1727     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1728     my $dh = DirHandle->new(File::Spec->curdir)
1729         or Carp::croak("Couldn't opendir $dir: $!");
1730     my(@entries);
1731     for ($dh->read) {
1732         next if $_ eq "." || $_ eq "..";
1733         if (-f $_) {
1734             push @entries, File::Spec->catfile($dir,$_);
1735         } elsif (-d _) {
1736             push @entries, File::Spec->catdir($dir,$_);
1737         } else {
1738             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1739         }
1740     }
1741     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1742     sort { -M $a <=> -M $b} @entries;
1743 }
1744
1745 #-> sub CPAN::CacheMgr::disk_usage ;
1746 sub disk_usage {
1747     my($self,$dir,$fast) = @_;
1748     return if exists $self->{SIZE}{$dir};
1749     return if $CPAN::Signal;
1750     my($Du) = 0;
1751     if (-e $dir) {
1752         if (-d $dir) {
1753             unless (-x $dir) {
1754                 unless (chmod 0755, $dir) {
1755                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1756                                             "permission to change the permission; cannot ".
1757                                             "estimate disk usage of '$dir'\n");
1758                     $CPAN::Frontend->mysleep(5);
1759                     return;
1760                 }
1761             }
1762         } elsif (-f $dir) {
1763             # nothing to say, no matter what the permissions
1764         }
1765     } else {
1766         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1767         return;
1768     }
1769     if ($fast) {
1770         $Du = 0; # placeholder
1771     } else {
1772         find(
1773              sub {
1774            $File::Find::prune++ if $CPAN::Signal;
1775            return if -l $_;
1776            if ($^O eq 'MacOS') {
1777              require Mac::Files;
1778              my $cat  = Mac::Files::FSpGetCatInfo($_);
1779              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1780            } else {
1781              if (-d _) {
1782                unless (-x _) {
1783                  unless (chmod 0755, $_) {
1784                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1785                                            "the permission to change the permission; ".
1786                                            "can only partially estimate disk usage ".
1787                                            "of '$_'\n");
1788                    $CPAN::Frontend->mysleep(5);
1789                    return;
1790                  }
1791                }
1792              } else {
1793                $Du += (-s _);
1794              }
1795            }
1796          },
1797          $dir
1798             );
1799     }
1800     return if $CPAN::Signal;
1801     $self->{SIZE}{$dir} = $Du/1024/1024;
1802     unshift @{$self->{FIFO}}, $dir;
1803     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1804     $self->{DU} += $Du/1024/1024;
1805     $self->{DU};
1806 }
1807
1808 #-> sub CPAN::CacheMgr::_clean_cache ;
1809 sub _clean_cache {
1810     my($self,$dir) = @_;
1811     return unless -e $dir;
1812     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1813             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1814         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1815                                 "will not remove\n");
1816         $CPAN::Frontend->mysleep(5);
1817         return;
1818     }
1819     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1820         if $CPAN::DEBUG;
1821     File::Path::rmtree($dir);
1822     my $id_deleted = 0;
1823     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1824         my $yaml_module = CPAN::_yaml_module;
1825         if ($CPAN::META->has_inst($yaml_module)) {
1826             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1827             if ($@) {
1828                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1829                 unlink "$dir.yml" or
1830                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1831                 return;
1832             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1833                 $CPAN::META->delete("CPAN::Distribution", $id);
1834
1835                 # XXX we should restore the state NOW, otherise this
1836                 # distro does not exist until we read an index. BUG ALERT(?)
1837
1838                 # $CPAN::Frontend->mywarn (" +++\n");
1839                 $id_deleted++;
1840             }
1841         }
1842         unlink "$dir.yml"; # may fail
1843         unless ($id_deleted) {
1844             CPAN->debug("no distro found associated with '$dir'");
1845         }
1846     }
1847     $self->{DU} -= $self->{SIZE}{$dir};
1848     delete $self->{SIZE}{$dir};
1849 }
1850
1851 #-> sub CPAN::CacheMgr::new ;
1852 sub new {
1853     my $class = shift;
1854     my $time = time;
1855     my($debug,$t2);
1856     $debug = "";
1857     my $self = {
1858         ID => $CPAN::Config->{build_dir},
1859         MAX => $CPAN::Config->{'build_cache'},
1860         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1861         DU => 0
1862     };
1863     File::Path::mkpath($self->{ID});
1864     my $dh = DirHandle->new($self->{ID});
1865     bless $self, $class;
1866     $self->scan_cache;
1867     $t2 = time;
1868     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1869     $time = $t2;
1870     CPAN->debug($debug) if $CPAN::DEBUG;
1871     $self;
1872 }
1873
1874 #-> sub CPAN::CacheMgr::scan_cache ;
1875 sub scan_cache {
1876     my $self = shift;
1877     return if $self->{SCAN} eq 'never';
1878     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1879         unless $self->{SCAN} eq 'atstart';
1880     return unless $CPAN::META->{LOCK};
1881     $CPAN::Frontend->myprint(
1882                              sprintf("Scanning cache %s for sizes\n",
1883                              $self->{ID}));
1884     my $e;
1885     my @entries = $self->entries($self->{ID});
1886     my $i = 0;
1887     my $painted = 0;
1888     for $e (@entries) {
1889         my $symbol = ".";
1890         if ($self->{DU} > $self->{MAX}) {
1891             $symbol = "-";
1892             $self->disk_usage($e,1);
1893         } else {
1894             $self->disk_usage($e);
1895         }
1896         $i++;
1897         while (($painted/76) < ($i/@entries)) {
1898             $CPAN::Frontend->myprint($symbol);
1899             $painted++;
1900         }
1901         return if $CPAN::Signal;
1902     }
1903     $CPAN::Frontend->myprint("DONE\n");
1904     $self->tidyup;
1905 }
1906
1907 package CPAN::Shell;
1908 use strict;
1909
1910 #-> sub CPAN::Shell::h ;
1911 sub h {
1912     my($class,$about) = @_;
1913     if (defined $about) {
1914         my $help;
1915         if (exists $Help->{$about}) {
1916             if (ref $Help->{$about}) { # aliases
1917                 $about = ${$Help->{$about}};
1918             }
1919             $help = $Help->{$about};
1920         } else {
1921             $help = "No help available";
1922         }
1923         $CPAN::Frontend->myprint("$about\: $help\n");
1924     } else {
1925         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1926         $CPAN::Frontend->myprint(qq{
1927 Display Information $filler (ver $CPAN::VERSION)
1928  command  argument          description
1929  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1930  i        WORD or /REGEXP/  about any of the above
1931  ls       AUTHOR or GLOB    about files in the author's directory
1932     (with WORD being a module, bundle or author name or a distribution
1933     name of the form AUTHOR/DISTRIBUTION)
1934
1935 Download, Test, Make, Install...
1936  get      download                     clean    make clean
1937  make     make (implies get)           look     open subshell in dist directory
1938  test     make test (implies make)     readme   display these README files
1939  install  make install (implies test)  perldoc  display POD documentation
1940
1941 Upgrade
1942  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1943  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1944
1945 Pragmas
1946  force  CMD    try hard to do command  fforce CMD    try harder
1947  notest CMD    skip testing
1948
1949 Other
1950  h,?           display this menu       ! perl-code   eval a perl command
1951  o conf [opt]  set and query options   q             quit the cpan shell
1952  reload cpan   load CPAN.pm again      reload index  load newer indices
1953  autobundle    Snapshot                recent        latest CPAN uploads});
1954 }
1955 }
1956
1957 *help = \&h;
1958
1959 #-> sub CPAN::Shell::a ;
1960 sub a {
1961   my($self,@arg) = @_;
1962   # authors are always UPPERCASE
1963   for (@arg) {
1964     $_ = uc $_ unless /=/;
1965   }
1966   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1967 }
1968
1969 #-> sub CPAN::Shell::globls ;
1970 sub globls {
1971     my($self,$s,$pragmas) = @_;
1972     # ls is really very different, but we had it once as an ordinary
1973     # command in the Shell (upto rev. 321) and we could not handle
1974     # force well then
1975     my(@accept,@preexpand);
1976     if ($s =~ /[\*\?\/]/) {
1977         if ($CPAN::META->has_inst("Text::Glob")) {
1978             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1979                 my $rau = Text::Glob::glob_to_regex(uc $au);
1980                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1981                       if $CPAN::DEBUG;
1982                 push @preexpand, map { $_->id . "/" . $pathglob }
1983                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1984             } else {
1985                 my $rau = Text::Glob::glob_to_regex(uc $s);
1986                 push @preexpand, map { $_->id }
1987                     CPAN::Shell->expand_by_method('CPAN::Author',
1988                                                   ['id'],
1989                                                   "/$rau/");
1990             }
1991         } else {
1992             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1993         }
1994     } else {
1995         push @preexpand, uc $s;
1996     }
1997     for (@preexpand) {
1998         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1999             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
2000             next;
2001         }
2002         push @accept, $_;
2003     }
2004     my $silent = @accept>1;
2005     my $last_alpha = "";
2006     my @results;
2007     for my $a (@accept) {
2008         my($author,$pathglob);
2009         if ($a =~ m|(.*?)/(.*)|) {
2010             my $a2 = $1;
2011             $pathglob = $2;
2012             $author = CPAN::Shell->expand_by_method('CPAN::Author',
2013                                                     ['id'],
2014                                                     $a2)
2015                 or $CPAN::Frontend->mydie("No author found for $a2\n");
2016         } else {
2017             $author = CPAN::Shell->expand_by_method('CPAN::Author',
2018                                                     ['id'],
2019                                                     $a)
2020                 or $CPAN::Frontend->mydie("No author found for $a\n");
2021         }
2022         if ($silent) {
2023             my $alpha = substr $author->id, 0, 1;
2024             my $ad;
2025             if ($alpha eq $last_alpha) {
2026                 $ad = "";
2027             } else {
2028                 $ad = "[$alpha]";
2029                 $last_alpha = $alpha;
2030             }
2031             $CPAN::Frontend->myprint($ad);
2032         }
2033         for my $pragma (@$pragmas) {
2034             if ($author->can($pragma)) {
2035                 $author->$pragma();
2036             }
2037         }
2038         push @results, $author->ls($pathglob,$silent); # silent if
2039                                                        # more than one
2040                                                        # author
2041         for my $pragma (@$pragmas) {
2042             my $unpragma = "un$pragma";
2043             if ($author->can($unpragma)) {
2044                 $author->$unpragma();
2045             }
2046         }
2047     }
2048     @results;
2049 }
2050
2051 #-> sub CPAN::Shell::local_bundles ;
2052 sub local_bundles {
2053     my($self,@which) = @_;
2054     my($incdir,$bdir,$dh);
2055     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
2056         my @bbase = "Bundle";
2057         while (my $bbase = shift @bbase) {
2058             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
2059             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
2060             if ($dh = DirHandle->new($bdir)) { # may fail
2061                 my($entry);
2062                 for $entry ($dh->read) {
2063                     next if $entry =~ /^\./;
2064                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
2065                     if (-d File::Spec->catdir($bdir,$entry)) {
2066                         push @bbase, "$bbase\::$entry";
2067                     } else {
2068                         next unless $entry =~ s/\.pm(?!\n)\Z//;
2069                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
2070                     }
2071                 }
2072             }
2073         }
2074     }
2075 }
2076
2077 #-> sub CPAN::Shell::b ;
2078 sub b {
2079     my($self,@which) = @_;
2080     CPAN->debug("which[@which]") if $CPAN::DEBUG;
2081     $self->local_bundles;
2082     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
2083 }
2084
2085 #-> sub CPAN::Shell::d ;
2086 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
2087
2088 #-> sub CPAN::Shell::m ;
2089 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
2090     my $self = shift;
2091     $CPAN::Frontend->myprint($self->format_result('Module',@_));
2092 }
2093
2094 #-> sub CPAN::Shell::i ;
2095 sub i {
2096     my($self) = shift;
2097     my(@args) = @_;
2098     @args = '/./' unless @args;
2099     my(@result);
2100     for my $type (qw/Bundle Distribution Module/) {
2101         push @result, $self->expand($type,@args);
2102     }
2103     # Authors are always uppercase.
2104     push @result, $self->expand("Author", map { uc $_ } @args);
2105
2106     my $result = @result == 1 ?
2107         $result[0]->as_string :
2108             @result == 0 ?
2109                 "No objects found of any type for argument @args\n" :
2110                     join("",
2111                          (map {$_->as_glimpse} @result),
2112                          scalar @result, " items found\n",
2113                         );
2114     $CPAN::Frontend->myprint($result);
2115 }
2116
2117 #-> sub CPAN::Shell::o ;
2118
2119 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
2120 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
2121 # probably have been called 'set' and 'o debug' maybe 'set debug' or
2122 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
2123 sub o {
2124     my($self,$o_type,@o_what) = @_;
2125     $o_type ||= "";
2126     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2127     if ($o_type eq 'conf') {
2128         my($cfilter);
2129         ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2130         if (!@o_what or $cfilter) { # print all things, "o conf"
2131             $cfilter ||= "";
2132             my $qrfilter = eval 'qr/$cfilter/';
2133             my($k,$v);
2134             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2135             my @from;
2136             if (exists $INC{'CPAN/Config.pm'}) {
2137                 push @from, $INC{'CPAN/Config.pm'};
2138             }
2139             if (exists $INC{'CPAN/MyConfig.pm'}) {
2140                 push @from, $INC{'CPAN/MyConfig.pm'};
2141             }
2142             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2143             $CPAN::Frontend->myprint(":\n");
2144             for $k (sort keys %CPAN::HandleConfig::can) {
2145                 next unless $k =~ /$qrfilter/;
2146                 $v = $CPAN::HandleConfig::can{$k};
2147                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2148             }
2149             $CPAN::Frontend->myprint("\n");
2150             for $k (sort keys %CPAN::HandleConfig::keys) {
2151                 next unless $k =~ /$qrfilter/;
2152                 CPAN::HandleConfig->prettyprint($k);
2153             }
2154             $CPAN::Frontend->myprint("\n");
2155         } else {
2156             if (CPAN::HandleConfig->edit(@o_what)) {
2157             } else {
2158                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2159                                          qq{items\n\n});
2160             }
2161         }
2162     } elsif ($o_type eq 'debug') {
2163         my(%valid);
2164         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2165         if (@o_what) {
2166             while (@o_what) {
2167                 my($what) = shift @o_what;
2168                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2169                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2170                     next;
2171                 }
2172                 if ( exists $CPAN::DEBUG{$what} ) {
2173                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2174                 } elsif ($what =~ /^\d/) {
2175                     $CPAN::DEBUG = $what;
2176                 } elsif (lc $what eq 'all') {
2177                     my($max) = 0;
2178                     for (values %CPAN::DEBUG) {
2179                         $max += $_;
2180                     }
2181                     $CPAN::DEBUG = $max;
2182                 } else {
2183                     my($known) = 0;
2184                     for (keys %CPAN::DEBUG) {
2185                         next unless lc($_) eq lc($what);
2186                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2187                         $known = 1;
2188                     }
2189                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
2190                         unless $known;
2191                 }
2192             }
2193         } else {
2194             my $raw = "Valid options for debug are ".
2195                 join(", ",sort(keys %CPAN::DEBUG), 'all').
2196                      qq{ or a number. Completion works on the options. }.
2197                      qq{Case is ignored.};
2198             require Text::Wrap;
2199             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2200             $CPAN::Frontend->myprint("\n\n");
2201         }
2202         if ($CPAN::DEBUG) {
2203             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2204             my($k,$v);
2205             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2206                 $v = $CPAN::DEBUG{$k};
2207                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2208                     if $v & $CPAN::DEBUG;
2209             }
2210         } else {
2211             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2212         }
2213     } else {
2214         $CPAN::Frontend->myprint(qq{
2215 Known options:
2216   conf    set or get configuration variables
2217   debug   set or get debugging options
2218 });
2219     }
2220 }
2221
2222 # CPAN::Shell::paintdots_onreload
2223 sub paintdots_onreload {
2224     my($ref) = shift;
2225     sub {
2226         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2227             my($subr) = $1;
2228             ++$$ref;
2229             local($|) = 1;
2230             # $CPAN::Frontend->myprint(".($subr)");
2231             $CPAN::Frontend->myprint(".");
2232             if ($subr =~ /\bshell\b/i) {
2233                 # warn "debug[$_[0]]";
2234
2235                 # It would be nice if we could detect that a
2236                 # subroutine has actually changed, but for now we
2237                 # practically always set the GOTOSHELL global
2238
2239                 $CPAN::GOTOSHELL=1;
2240             }
2241             return;
2242         }
2243         warn @_;
2244     };
2245 }
2246
2247 #-> sub CPAN::Shell::hosts ;
2248 sub hosts {
2249     my($self) = @_;
2250     my $fullstats = CPAN::FTP->_ftp_statistics();
2251     my $history = $fullstats->{history} || [];
2252     my %S; # statistics
2253     while (my $last = pop @$history) {
2254         my $attempts = $last->{attempts} or next;
2255         my $start;
2256         if (@$attempts) {
2257             $start = $attempts->[-1]{start};
2258             if ($#$attempts > 0) {
2259                 for my $i (0..$#$attempts-1) {
2260                     my $url = $attempts->[$i]{url} or next;
2261                     $S{no}{$url}++;
2262                 }
2263             }
2264         } else {
2265             $start = $last->{start};
2266         }
2267         next unless $last->{thesiteurl}; # C-C? bad filenames?
2268         $S{start} = $start;
2269         $S{end} ||= $last->{end};
2270         my $dltime = $last->{end} - $start;
2271         my $dlsize = $last->{filesize} || 0;
2272         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2273         my $s = $S{ok}{$url} ||= {};
2274         $s->{n}++;
2275         $s->{dlsize} ||= 0;
2276         $s->{dlsize} += $dlsize/1024;
2277         $s->{dltime} ||= 0;
2278         $s->{dltime} += $dltime;
2279     }
2280     my $res;
2281     for my $url (keys %{$S{ok}}) {
2282         next if $S{ok}{$url}{dltime} == 0; # div by zero
2283         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2284                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2285                              $url,
2286                             ];
2287     }
2288     for my $url (keys %{$S{no}}) {
2289         push @{$res->{no}}, [$S{no}{$url},
2290                              $url,
2291                             ];
2292     }
2293     my $R = ""; # report
2294     if ($S{start} && $S{end}) {
2295         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2296         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2297     }
2298     if ($res->{ok} && @{$res->{ok}}) {
2299         $R .= sprintf "\nSuccessful downloads:
2300    N       kB  secs      kB/s url\n";
2301         my $i = 20;
2302         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2303             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2304             last if --$i<=0;
2305         }
2306     }
2307     if ($res->{no} && @{$res->{no}}) {
2308         $R .= sprintf "\nUnsuccessful downloads:\n";
2309         my $i = 20;
2310         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2311             $R .= sprintf "%4d %s\n", @$_;
2312             last if --$i<=0;
2313         }
2314     }
2315     $CPAN::Frontend->myprint($R);
2316 }
2317
2318 # here is where 'reload cpan' is done
2319 #-> sub CPAN::Shell::reload ;
2320 sub reload {
2321     my($self,$command,@arg) = @_;
2322     $command ||= "";
2323     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2324     if ($command =~ /^cpan$/i) {
2325         my $redef = 0;
2326         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2327         my $failed;
2328       MFILE: for my $f (@relo) {
2329             next unless exists $INC{$f};
2330             my $p = $f;
2331             $p =~ s/\.pm$//;
2332             $p =~ s|/|::|g;
2333             $CPAN::Frontend->myprint("($p");
2334             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2335             $self->_reload_this($f) or $failed++;
2336             my $v = eval "$p\::->VERSION";
2337             $CPAN::Frontend->myprint("v$v)");
2338         }
2339         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2340         if ($failed) {
2341             my $errors = $failed == 1 ? "error" : "errors";
2342             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2343                                     "this session.\n");
2344         }
2345     } elsif ($command =~ /^index$/i) {
2346       CPAN::Index->force_reload;
2347     } else {
2348       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2349 index    re-reads the index files\n});
2350     }
2351 }
2352
2353 # reload means only load again what we have loaded before
2354 #-> sub CPAN::Shell::_reload_this ;
2355 sub _reload_this {
2356     my($self,$f,$args) = @_;
2357     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2358     return 1 unless $INC{$f}; # we never loaded this, so we do not
2359                               # reload but say OK
2360     my $pwd = CPAN::anycwd();
2361     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2362     my($file);
2363     for my $inc (@INC) {
2364         $file = File::Spec->catfile($inc,split /\//, $f);
2365         last if -f $file;
2366         $file = "";
2367     }
2368     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2369     my @inc = @INC;
2370     unless ($file && -f $file) {
2371         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2372         $file = $INC{$f};
2373         unless (CPAN->has_inst("File::Basename")) {
2374             @inc = File::Basename::dirname($file);
2375         } else {
2376             # do we ever need this?
2377             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2378         }
2379     }
2380     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2381     unless (-f $file) {
2382         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2383         return;
2384     }
2385     my $mtime = (stat $file)[9];
2386     $reload->{$f} ||= -1;
2387     my $must_reload = $mtime != $reload->{$f};
2388     $args ||= {};
2389     $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2390     if ($must_reload) {
2391         my $fh = FileHandle->new($file) or
2392             $CPAN::Frontend->mydie("Could not open $file: $!");
2393         local($/);
2394         local $^W = 1;
2395         my $content = <$fh>;
2396         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2397             if $CPAN::DEBUG;
2398         delete $INC{$f};
2399         local @INC = @inc;
2400         eval "require '$f'";
2401         if ($@) {
2402             warn $@;
2403             return;
2404         }
2405         $reload->{$f} = $mtime;
2406     } else {
2407         $CPAN::Frontend->myprint("__unchanged__");
2408     }
2409     return 1;
2410 }
2411
2412 #-> sub CPAN::Shell::mkmyconfig ;
2413 sub mkmyconfig {
2414     my($self, $cpanpm, %args) = @_;
2415     require CPAN::FirstTime;
2416     my $home = CPAN::HandleConfig::home;
2417     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2418         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2419     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2420     CPAN::HandleConfig::require_myconfig_or_config;
2421     $CPAN::Config ||= {};
2422     $CPAN::Config = {
2423         %$CPAN::Config,
2424         build_dir           =>  undef,
2425         cpan_home           =>  undef,
2426         keep_source_where   =>  undef,
2427         histfile            =>  undef,
2428     };
2429     CPAN::FirstTime::init($cpanpm, %args);
2430 }
2431
2432 #-> sub CPAN::Shell::_binary_extensions ;
2433 sub _binary_extensions {
2434     my($self) = shift @_;
2435     my(@result,$module,%seen,%need,$headerdone);
2436     for $module ($self->expand('Module','/./')) {
2437         my $file  = $module->cpan_file;
2438         next if $file eq "N/A";
2439         next if $file =~ /^Contact Author/;
2440         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2441         next if $dist->isa_perl;
2442         next unless $module->xs_file;
2443         local($|) = 1;
2444         $CPAN::Frontend->myprint(".");
2445         push @result, $module;
2446     }
2447 #    print join " | ", @result;
2448     $CPAN::Frontend->myprint("\n");
2449     return @result;
2450 }
2451
2452 #-> sub CPAN::Shell::recompile ;
2453 sub recompile {
2454     my($self) = shift @_;
2455     my($module,@module,$cpan_file,%dist);
2456     @module = $self->_binary_extensions();
2457     for $module (@module) { # we force now and compile later, so we
2458                             # don't do it twice
2459         $cpan_file = $module->cpan_file;
2460         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2461         $pack->force;
2462         $dist{$cpan_file}++;
2463     }
2464     for $cpan_file (sort keys %dist) {
2465         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2466         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2467         $pack->install;
2468         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2469                            # stop a package from recompiling,
2470                            # e.g. IO-1.12 when we have perl5.003_10
2471     }
2472 }
2473
2474 #-> sub CPAN::Shell::scripts ;
2475 sub scripts {
2476     my($self, $arg) = @_;
2477     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2478
2479     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2480         unless ($CPAN::META->has_inst($req)) {
2481             $CPAN::Frontend->mywarn("  $req not available\n");
2482         }
2483     }
2484     my $p = HTML::LinkExtor->new();
2485     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2486     unless (-f $indexfile) {
2487         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2488     }
2489     $p->parse_file($indexfile);
2490     my @hrefs;
2491     my $qrarg;
2492     if ($arg =~ s|^/(.+)/$|$1|) {
2493         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2494     }
2495     for my $l ($p->links) {
2496         my $tag = shift @$l;
2497         next unless $tag eq "a";
2498         my %att = @$l;
2499         my $href = $att{href};
2500         next unless $href =~ s|^\.\./authors/id/./../||;
2501         if ($arg) {
2502             if ($qrarg) {
2503                 if ($href =~ $qrarg) {
2504                     push @hrefs, $href;
2505                 }
2506             } else {
2507                 if ($href =~ /\Q$arg\E/) {
2508                     push @hrefs, $href;
2509                 }
2510             }
2511         } else {
2512             push @hrefs, $href;
2513         }
2514     }
2515     # now filter for the latest version if there is more than one of a name
2516     my %stems;
2517     for (sort @hrefs) {
2518         my $href = $_;
2519         s/-v?\d.*//;
2520         my $stem = $_;
2521         $stems{$stem} ||= [];
2522         push @{$stems{$stem}}, $href;
2523     }
2524     for (sort keys %stems) {
2525         my $highest;
2526         if (@{$stems{$_}} > 1) {
2527             $highest = List::Util::reduce {
2528                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2529               } @{$stems{$_}};
2530         } else {
2531             $highest = $stems{$_}[0];
2532         }
2533         $CPAN::Frontend->myprint("$highest\n");
2534     }
2535 }
2536
2537 #-> sub CPAN::Shell::report ;
2538 sub report {
2539     my($self,@args) = @_;
2540     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2541         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2542     }
2543     local $CPAN::Config->{test_report} = 1;
2544     $self->force("test",@args); # force is there so that the test be
2545                                 # re-run (as documented)
2546 }
2547
2548 # compare with is_tested
2549 #-> sub CPAN::Shell::install_tested
2550 sub install_tested {
2551     my($self,@some) = @_;
2552     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2553         return if @some;
2554     CPAN::Index->reload;
2555
2556     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2557         my $yaml = "$b.yml";
2558         unless (-f $yaml) {
2559             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2560             next;
2561         }
2562         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2563         my $id = $yaml_content->[0]{distribution}{ID};
2564         unless ($id) {
2565             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2566             next;
2567         }
2568         my $do = CPAN::Shell->expandany($id);
2569         unless ($do) {
2570             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2571             next;
2572         }
2573         unless ($do->{build_dir}) {
2574             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2575             next;
2576         }
2577         unless ($do->{build_dir} eq $b) {
2578             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2579             next;
2580         }
2581         push @some, $do;
2582     }
2583
2584     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2585         return unless @some;
2586
2587     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2588     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2589         return unless @some;
2590
2591     # @some = grep { not $_->uptodate } @some;
2592     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2593     #     return unless @some;
2594
2595     CPAN->debug("some[@some]");
2596     for my $d (@some) {
2597         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2598         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2599         $CPAN::Frontend->mysleep(1);
2600         $self->install($d);
2601     }
2602 }
2603
2604 #-> sub CPAN::Shell::upgrade ;
2605 sub upgrade {
2606     my($self,@args) = @_;
2607     $self->install($self->r(@args));
2608 }
2609
2610 #-> sub CPAN::Shell::_u_r_common ;
2611 sub _u_r_common {
2612     my($self) = shift @_;
2613     my($what) = shift @_;
2614     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2615     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2616           $what && $what =~ /^[aru]$/;
2617     my(@args) = @_;
2618     @args = '/./' unless @args;
2619     my(@result,$module,%seen,%need,$headerdone,
2620        $version_undefs,$version_zeroes,
2621        @version_undefs,@version_zeroes);
2622     $version_undefs = $version_zeroes = 0;
2623     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2624     my @expand = $self->expand('Module',@args);
2625     if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
2626              # for metadata cache
2627         my $expand = scalar @expand;
2628         $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
2629     }
2630     my @sexpand;
2631     if ($] < 5.008) {
2632         # hard to believe that the more complex sorting can lead to
2633         # stack curruptions on older perl
2634         @sexpand = sort {$a->id cmp $b->id} @expand;
2635     } else {
2636         @sexpand = map {
2637             $_->[1]
2638         } sort {
2639             $b->[0] <=> $a->[0]
2640             ||
2641             $a->[1]{ID} cmp $b->[1]{ID},
2642         } map {
2643             [$_->_is_representative_module,
2644              $_
2645             ]
2646         } @expand;
2647     }
2648     if ($CPAN::DEBUG) {
2649         $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
2650         sleep 1;
2651     }
2652   MODULE: for $module (@sexpand) {
2653         my $file  = $module->cpan_file;
2654         next MODULE unless defined $file; # ??
2655         $file =~ s!^./../!!;
2656         my($latest) = $module->cpan_version;
2657         my($inst_file) = $module->inst_file;
2658         CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
2659         my($have);
2660         return if $CPAN::Signal;
2661         my($next_MODULE);
2662         eval { # version.pm involved!
2663             if ($inst_file) {
2664                 if ($what eq "a") {
2665                     $have = $module->inst_version;
2666                 } elsif ($what eq "r") {
2667                     $have = $module->inst_version;
2668                     local($^W) = 0;
2669                     if ($have eq "undef") {
2670                         $version_undefs++;
2671                         push @version_undefs, $module->as_glimpse;
2672                     } elsif (CPAN::Version->vcmp($have,0)==0) {
2673                         $version_zeroes++;
2674                         push @version_zeroes, $module->as_glimpse;
2675                     }
2676                     ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
2677                     # to be pedantic we should probably say:
2678                     #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2679                     # to catch the case where CPAN has a version 0 and we have a version undef
2680                 } elsif ($what eq "u") {
2681                     ++$next_MODULE;
2682                 }
2683             } else {
2684                 if ($what eq "a") {
2685                     ++$next_MODULE;
2686                 } elsif ($what eq "r") {
2687                     ++$next_MODULE;
2688                 } elsif ($what eq "u") {
2689                     $have = "-";
2690                 }
2691             }
2692         };
2693         next MODULE if $next_MODULE;
2694         if ($@) {
2695             $CPAN::Frontend->mywarn
2696                 (sprintf("Error while comparing cpan/installed versions of '%s':
2697 INST_FILE: %s
2698 INST_VERSION: %s %s
2699 CPAN_VERSION: %s %s
2700 ",
2701                          $module->id,
2702                          $inst_file || "",
2703                          (defined $have ? $have : "[UNDEFINED]"),
2704                          (ref $have ? ref $have : ""),
2705                          $latest,
2706                          (ref $latest ? ref $latest : ""),
2707                         ));
2708             next MODULE;
2709         }
2710         return if $CPAN::Signal; # this is sometimes lengthy
2711         $seen{$file} ||= 0;
2712         if ($what eq "a") {
2713             push @result, sprintf "%s %s\n", $module->id, $have;
2714         } elsif ($what eq "r") {
2715             push @result, $module->id;
2716             next MODULE if $seen{$file}++;
2717         } elsif ($what eq "u") {
2718             push @result, $module->id;
2719             next MODULE if $seen{$file}++;
2720             next MODULE if $file =~ /^Contact/;
2721         }
2722         unless ($headerdone++) {
2723             $CPAN::Frontend->myprint("\n");
2724             $CPAN::Frontend->myprint(sprintf(
2725                                              $sprintf,
2726                                              "",
2727                                              "Package namespace",
2728                                              "",
2729                                              "installed",
2730                                              "latest",
2731                                              "in CPAN file"
2732                                             ));
2733         }
2734         my $color_on = "";
2735         my $color_off = "";
2736         if (
2737             $COLOR_REGISTERED
2738             &&
2739             $CPAN::META->has_inst("Term::ANSIColor")
2740             &&
2741             $module->description
2742            ) {
2743             $color_on = Term::ANSIColor::color("green");
2744             $color_off = Term::ANSIColor::color("reset");
2745         }
2746         $CPAN::Frontend->myprint(sprintf $sprintf,
2747                                  $color_on,
2748                                  $module->id,
2749                                  $color_off,
2750                                  $have,
2751                                  $latest,
2752                                  $file);
2753         $need{$module->id}++;
2754     }
2755     unless (%need) {
2756         if ($what eq "u") {
2757             $CPAN::Frontend->myprint("No modules found for @args\n");
2758         } elsif ($what eq "r") {
2759             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2760         }
2761     }
2762     if ($what eq "r") {
2763         if ($version_zeroes) {
2764             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2765             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2766                                      qq{a version number of 0\n});
2767             if ($CPAN::Config->{show_zero_versions}) {
2768                 local $" = "\t";
2769                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2770                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2771                                          qq{to hide them)\n});
2772             } else {
2773                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2774                                          qq{to show them)\n});
2775             }
2776         }
2777         if ($version_undefs) {
2778             my $s_has = $version_undefs > 1 ? "s have" : " has";
2779             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2780                                      qq{parseable version number\n});
2781             if ($CPAN::Config->{show_unparsable_versions}) {
2782                 local $" = "\t";
2783                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2784                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2785                                          qq{to hide them)\n});
2786             } else {
2787                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2788                                          qq{to show them)\n});
2789             }
2790         }
2791     }
2792     @result;
2793 }
2794
2795 #-> sub CPAN::Shell::r ;
2796 sub r {
2797     shift->_u_r_common("r",@_);
2798 }
2799
2800 #-> sub CPAN::Shell::u ;
2801 sub u {
2802     shift->_u_r_common("u",@_);
2803 }
2804
2805 #-> sub CPAN::Shell::failed ;
2806 sub failed {
2807     my($self,$only_id,$silent) = @_;
2808     my @failed;
2809   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2810         my $failed = "";
2811       NAY: for my $nosayer ( # order matters!
2812                             "unwrapped",
2813                             "writemakefile",
2814                             "signature_verify",
2815                             "make",
2816                             "make_test",
2817                             "install",
2818                             "make_clean",
2819                            ) {
2820             next unless exists $d->{$nosayer};
2821             next unless defined $d->{$nosayer};
2822             next unless (
2823                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2824                          $d->{$nosayer}->failed :
2825                          $d->{$nosayer} =~ /^NO/
2826                         );
2827             next NAY if $only_id && $only_id != (
2828                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2829                                                  ?
2830                                                  $d->{$nosayer}->commandid
2831                                                  :
2832                                                  $CPAN::CurrentCommandId
2833                                                 );
2834             $failed = $nosayer;
2835             last;
2836         }
2837         next DIST unless $failed;
2838         my $id = $d->id;
2839         $id =~ s|^./../||;
2840         #$print .= sprintf(
2841         #                  "  %-45s: %s %s\n",
2842         push @failed,
2843             (
2844              UNIVERSAL::can($d->{$failed},"failed") ?
2845              [
2846               $d->{$failed}->commandid,
2847               $id,
2848               $failed,
2849               $d->{$failed}->text,
2850               $d->{$failed}{TIME}||0,
2851              ] :
2852              [
2853               1,
2854               $id,
2855               $failed,
2856               $d->{$failed},
2857               0,
2858              ]
2859             );
2860     }
2861     my $scope;
2862     if ($only_id) {
2863         $scope = "this command";
2864     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2865         $scope = "this or a previous session";
2866         # it might be nice to have a section for previous session and
2867         # a second for this
2868     } else {
2869         $scope = "this session";
2870     }
2871     if (@failed) {
2872         my $print;
2873         my $debug = 0;
2874         if ($debug) {
2875             $print = join "",
2876                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2877                     sort { $a->[0] <=> $b->[0] } @failed;
2878         } else {
2879             $print = join "",
2880                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2881                     sort {
2882                         $a->[0] <=> $b->[0]
2883                             ||
2884                                 $a->[4] <=> $b->[4]
2885                        } @failed;
2886         }
2887         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2888     } elsif (!$only_id || !$silent) {
2889         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2890     }
2891 }
2892
2893 # XXX intentionally undocumented because completely bogus, unportable,
2894 # useless, etc.
2895
2896 #-> sub CPAN::Shell::status ;
2897 sub status {
2898     my($self) = @_;
2899     require Devel::Size;
2900     my $ps = FileHandle->new;
2901     open $ps, "/proc/$$/status";
2902     my $vm = 0;
2903     while (<$ps>) {
2904         next unless /VmSize:\s+(\d+)/;
2905         $vm = $1;
2906         last;
2907     }
2908     $CPAN::Frontend->mywarn(sprintf(
2909                                     "%-27s %6d\n%-27s %6d\n",
2910                                     "vm",
2911                                     $vm,
2912                                     "CPAN::META",
2913                                     Devel::Size::total_size($CPAN::META)/1024,
2914                                    ));
2915     for my $k (sort keys %$CPAN::META) {
2916         next unless substr($k,0,4) eq "read";
2917         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2918         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2919             warn sprintf "  %-25s %6d (keys: %6d)\n",
2920                 $k2,
2921                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2922                           scalar keys %{$CPAN::META->{$k}{$k2}};
2923         }
2924     }
2925 }
2926
2927 # compare with install_tested
2928 #-> sub CPAN::Shell::is_tested
2929 sub is_tested {
2930     my($self) = @_;
2931     CPAN::Index->reload;
2932     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2933         my $time;
2934         if ($CPAN::META->{is_tested}{$b}) {
2935             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2936         } else {
2937             $time = scalar localtime;
2938             $time =~ s/\S/?/g;
2939         }
2940         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2941     }
2942 }
2943
2944 #-> sub CPAN::Shell::autobundle ;
2945 sub autobundle {
2946     my($self) = shift;
2947     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2948     my(@bundle) = $self->_u_r_common("a",@_);
2949     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2950     File::Path::mkpath($todir);
2951     unless (-d $todir) {
2952         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2953         return;
2954     }
2955     my($y,$m,$d) =  (localtime)[5,4,3];
2956     $y+=1900;
2957     $m++;
2958     my($c) = 0;
2959     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2960     my($to) = File::Spec->catfile($todir,"$me.pm");
2961     while (-f $to) {
2962         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2963         $to = File::Spec->catfile($todir,"$me.pm");
2964     }
2965     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2966     $fh->print(
2967                "package Bundle::$me;\n\n",
2968                "\$VERSION = '0.01';\n\n",
2969                "1;\n\n",
2970                "__END__\n\n",
2971                "=head1 NAME\n\n",
2972                "Bundle::$me - Snapshot of installation on ",
2973                $Config::Config{'myhostname'},
2974                " on ",
2975                scalar(localtime),
2976                "\n\n=head1 SYNOPSIS\n\n",
2977                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2978                "=head1 CONTENTS\n\n",
2979                join("\n", @bundle),
2980                "\n\n=head1 CONFIGURATION\n\n",
2981                Config->myconfig,
2982                "\n\n=head1 AUTHOR\n\n",
2983                "This Bundle has been generated automatically ",
2984                "by the autobundle routine in CPAN.pm.\n",
2985               );
2986     $fh->close;
2987     $CPAN::Frontend->myprint("\nWrote bundle file
2988     $to\n\n");
2989 }
2990
2991 #-> sub CPAN::Shell::expandany ;
2992 sub expandany {
2993     my($self,$s) = @_;
2994     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2995     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2996         $s = CPAN::Distribution->normalize($s);
2997         return $CPAN::META->instance('CPAN::Distribution',$s);
2998         # Distributions spring into existence, not expand
2999     } elsif ($s =~ m|^Bundle::|) {
3000         $self->local_bundles; # scanning so late for bundles seems
3001                               # both attractive and crumpy: always
3002                               # current state but easy to forget
3003                               # somewhere
3004         return $self->expand('Bundle',$s);
3005     } else {
3006         return $self->expand('Module',$s)
3007             if $CPAN::META->exists('CPAN::Module',$s);
3008     }
3009     return;
3010 }
3011
3012 #-> sub CPAN::Shell::expand ;
3013 sub expand {
3014     my $self = shift;
3015     my($type,@args) = @_;
3016     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
3017     my $class = "CPAN::$type";
3018     my $methods = ['id'];
3019     for my $meth (qw(name)) {
3020         next unless $class->can($meth);
3021         push @$methods, $meth;
3022     }
3023     $self->expand_by_method($class,$methods,@args);
3024 }
3025
3026 #-> sub CPAN::Shell::expand_by_method ;
3027 sub expand_by_method {
3028     my $self = shift;
3029     my($class,$methods,@args) = @_;
3030     my($arg,@m);
3031     for $arg (@args) {
3032         my($regex,$command);
3033         if ($arg =~ m|^/(.*)/$|) {
3034             $regex = $1;
3035 # FIXME:  there seem to be some ='s in the author data, which trigger
3036 #         a failure here.  This needs to be contemplated.
3037 #            } elsif ($arg =~ m/=/) {
3038 #                $command = 1;
3039         }
3040         my $obj;
3041         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
3042                     $class,
3043                     defined $regex ? $regex : "UNDEFINED",
3044                     defined $command ? $command : "UNDEFINED",
3045                    ) if $CPAN::DEBUG;
3046         if (defined $regex) {
3047             if (CPAN::_sqlite_running) {
3048                 CPAN::Index->reload;
3049                 $CPAN::SQLite->search($class, $regex);
3050             }
3051             for $obj (
3052                       $CPAN::META->all_objects($class)
3053                      ) {
3054                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
3055                     # BUG, we got an empty object somewhere
3056                     require Data::Dumper;
3057                     CPAN->debug(sprintf(
3058                                         "Bug in CPAN: Empty id on obj[%s][%s]",
3059                                         $obj,
3060                                         Data::Dumper::Dumper($obj)
3061                                        )) if $CPAN::DEBUG;
3062                     next;
3063                 }
3064                 for my $method (@$methods) {
3065                     my $match = eval {$obj->$method() =~ /$regex/i};
3066                     if ($@) {
3067                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
3068                         $err ||= $@; # if we were too restrictive above
3069                         $CPAN::Frontend->mydie("$err\n");
3070                     } elsif ($match) {
3071                         push @m, $obj;
3072                         last;
3073                     }
3074                 }
3075             }
3076         } elsif ($command) {
3077             die "equal sign in command disabled (immature interface), ".
3078                 "you can set
3079  ! \$CPAN::Shell::ADVANCED_QUERY=1
3080 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
3081 that may go away anytime.\n"
3082                     unless $ADVANCED_QUERY;
3083             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
3084             my($matchcrit) = $criterion =~ m/^~(.+)/;
3085             for my $self (
3086                           sort
3087                           {$a->id cmp $b->id}
3088                           $CPAN::META->all_objects($class)
3089                          ) {
3090                 my $lhs = $self->$method() or next; # () for 5.00503
3091                 if ($matchcrit) {
3092                     push @m, $self if $lhs =~ m/$matchcrit/;
3093                 } else {
3094                     push @m, $self if $lhs eq $criterion;
3095                 }
3096             }
3097         } else {
3098             my($xarg) = $arg;
3099             if ( $class eq 'CPAN::Bundle' ) {
3100                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
3101             } elsif ($class eq "CPAN::Distribution") {
3102                 $xarg = CPAN::Distribution->normalize($arg);
3103             } else {
3104                 $xarg =~ s/:+/::/g;
3105             }
3106             if ($CPAN::META->exists($class,$xarg)) {
3107                 $obj = $CPAN::META->instance($class,$xarg);
3108             } elsif ($CPAN::META->exists($class,$arg)) {
3109                 $obj = $CPAN::META->instance($class,$arg);
3110             } else {
3111                 next;
3112             }
3113             push @m, $obj;
3114         }
3115     }
3116     @m = sort {$a->id cmp $b->id} @m;
3117     if ( $CPAN::DEBUG ) {
3118         my $wantarray = wantarray;
3119         my $join_m = join ",", map {$_->id} @m;
3120         # $self->debug("wantarray[$wantarray]join_m[$join_m]");
3121         my $count = scalar @m;
3122         $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
3123     }
3124     return wantarray ? @m : $m[0];
3125 }
3126
3127 #-> sub CPAN::Shell::format_result ;
3128 sub format_result {
3129     my($self) = shift;
3130     my($type,@args) = @_;
3131     @args = '/./' unless @args;
3132     my(@result) = $self->expand($type,@args);
3133     my $result = @result == 1 ?
3134         $result[0]->as_string :
3135             @result == 0 ?
3136                 "No objects of type $type found for argument @args\n" :
3137                     join("",
3138                          (map {$_->as_glimpse} @result),
3139                          scalar @result, " items found\n",
3140                         );
3141     $result;
3142 }
3143
3144 #-> sub CPAN::Shell::report_fh ;
3145 {
3146     my $installation_report_fh;
3147     my $previously_noticed = 0;
3148
3149     sub report_fh {
3150         return $installation_report_fh if $installation_report_fh;
3151         if ($CPAN::META->has_usable("File::Temp")) {
3152             $installation_report_fh
3153                 = File::Temp->new(
3154                                   dir      => File::Spec->tmpdir,
3155                                   template => 'cpan_install_XXXX',
3156                                   suffix   => '.txt',
3157                                   unlink   => 0,
3158                                  );
3159         }
3160         unless ( $installation_report_fh ) {
3161             warn("Couldn't open installation report file; " .
3162                  "no report file will be generated."
3163                 ) unless $previously_noticed++;
3164         }
3165     }
3166 }
3167
3168
3169 # The only reason for this method is currently to have a reliable
3170 # debugging utility that reveals which output is going through which
3171 # channel. No, I don't like the colors ;-)
3172
3173 # to turn colordebugging on, write
3174 # cpan> o conf colorize_output 1
3175
3176 #-> sub CPAN::Shell::colorize_output ;
3177 {
3178     my $print_ornamented_have_warned = 0;
3179     sub colorize_output {
3180         my $colorize_output = $CPAN::Config->{colorize_output};
3181         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3182             unless ($print_ornamented_have_warned++) {
3183                 # no myprint/mywarn within myprint/mywarn!
3184                 warn "Colorize_output is set to true but Term::ANSIColor is not
3185 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3186             }
3187             $colorize_output = 0;
3188         }
3189         return $colorize_output;
3190     }
3191 }
3192
3193
3194 #-> sub CPAN::Shell::print_ornamented ;
3195 sub print_ornamented {
3196     my($self,$what,$ornament) = @_;
3197     return unless defined $what;
3198
3199     local $| = 1; # Flush immediately
3200     if ( $CPAN::Be_Silent ) {
3201         print {report_fh()} $what;
3202         return;
3203     }
3204     my $swhat = "$what"; # stringify if it is an object
3205     if ($CPAN::Config->{term_is_latin}) {
3206         # note: deprecated, need to switch to $LANG and $LC_*
3207         # courtesy jhi:
3208         $swhat
3209             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3210     }
3211     if ($self->colorize_output) {
3212         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3213             # if you want to have this configurable, please file a bugreport
3214             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3215         }
3216         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3217         if ($@) {
3218             print "Term::ANSIColor rejects color[$ornament]: $@\n
3219 Please choose a different color (Hint: try 'o conf init /color/')\n";
3220         }
3221         # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
3222         # $trailer construct. We want the newline be the last thing if
3223         # there is a newline at the end ensuring that the next line is
3224         # empty for other players
3225         my $trailer = "";
3226         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3227         print $color_on,
3228             $swhat,
3229                 Term::ANSIColor::color("reset"),
3230                       $trailer;
3231     } else {
3232         print $swhat;
3233     }
3234 }
3235
3236 #-> sub CPAN::Shell::myprint ;
3237
3238 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3239 # I think, we send everything to STDOUT and use print for normal/good
3240 # news and warn for news that need more attention. Yes, this is our
3241 # working contract for now.
3242 sub myprint {
3243     my($self,$what) = @_;
3244     $self->print_ornamented($what,
3245                             $CPAN::Config->{colorize_print}||'bold blue on_white',
3246                            );
3247 }
3248
3249 sub optprint {
3250     my($self,$category,$what) = @_;
3251     my $vname = $category . "_verbosity";
3252     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3253     if (!$CPAN::Config->{$vname}
3254         || $CPAN::Config->{$vname} =~ /^v/
3255        ) {
3256         $CPAN::Frontend->myprint($what);
3257     }
3258 }
3259
3260 #-> sub CPAN::Shell::myexit ;
3261 sub myexit {
3262     my($self,$what) = @_;
3263     $self->myprint($what);
3264     exit;
3265 }
3266
3267 #-> sub CPAN::Shell::mywarn ;
3268 sub mywarn {
3269     my($self,$what) = @_;
3270     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3271 }
3272
3273 # only to be used for shell commands
3274 #-> sub CPAN::Shell::mydie ;
3275 sub mydie {
3276     my($self,$what) = @_;
3277     $self->mywarn($what);
3278
3279     # If it is the shell, we want the following die to be silent,
3280     # but if it is not the shell, we would need a 'die $what'. We need
3281     # to take care that only shell commands use mydie. Is this
3282     # possible?
3283
3284     die "\n";
3285 }
3286
3287 # sub CPAN::Shell::colorable_makemaker_prompt ;
3288 sub colorable_makemaker_prompt {
3289     my($foo,$bar) = @_;
3290     if (CPAN::Shell->colorize_output) {
3291         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3292         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3293         print $color_on;
3294     }
3295     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3296     if (CPAN::Shell->colorize_output) {
3297         print Term::ANSIColor::color('reset');
3298     }
3299     return $ans;
3300 }
3301
3302 # use this only for unrecoverable errors!
3303 #-> sub CPAN::Shell::unrecoverable_error ;
3304 sub unrecoverable_error {
3305     my($self,$what) = @_;
3306     my @lines = split /\n/, $what;
3307     my $longest = 0;
3308     for my $l (@lines) {
3309         $longest = length $l if length $l > $longest;
3310     }
3311     $longest = 62 if $longest > 62;
3312     for my $l (@lines) {
3313         if ($l =~ /^\s*$/) {
3314             $l = "\n";
3315             next;
3316         }
3317         $l = "==> $l";
3318         if (length $l < 66) {
3319             $l = pack "A66 A*", $l, "<==";
3320         }
3321         $l .= "\n";
3322     }
3323     unshift @lines, "\n";
3324     $self->mydie(join "", @lines);
3325 }
3326
3327 #-> sub CPAN::Shell::mysleep ;
3328 sub mysleep {
3329     my($self, $sleep) = @_;
3330     if (CPAN->has_inst("Time::HiRes")) {
3331         Time::HiRes::sleep($sleep);
3332     } else {
3333         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3334     }
3335 }
3336
3337 #-> sub CPAN::Shell::setup_output ;
3338 sub setup_output {
3339     return if -t STDOUT;
3340     my $odef = select STDERR;
3341     $| = 1;
3342     select STDOUT;
3343     $| = 1;
3344     select $odef;
3345 }
3346
3347 #-> sub CPAN::Shell::rematein ;
3348 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3349 sub rematein {
3350     my $self = shift;
3351     my($meth,@some) = @_;
3352     my @pragma;
3353     while($meth =~ /^(ff?orce|notest)$/) {
3354         push @pragma, $meth;
3355         $meth = shift @some or
3356             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3357                                    "cannot continue");
3358     }
3359     setup_output();
3360     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3361
3362     # Here is the place to set "test_count" on all involved parties to
3363     # 0. We then can pass this counter on to the involved
3364     # distributions and those can refuse to test if test_count > X. In
3365     # the first stab at it we could use a 1 for "X".
3366
3367     # But when do I reset the distributions to start with 0 again?
3368     # Jost suggested to have a random or cycling interaction ID that
3369     # we pass through. But the ID is something that is just left lying
3370     # around in addition to the counter, so I'd prefer to set the
3371     # counter to 0 now, and repeat at the end of the loop. But what
3372     # about dependencies? They appear later and are not reset, they
3373     # enter the queue but not its copy. How do they get a sensible
3374     # test_count?
3375
3376     # With configure_requires, "get" is vulnerable in recursion.
3377
3378     my $needs_recursion_protection = "get|make|test|install";
3379
3380     # construct the queue
3381     my($s,@s,@qcopy);
3382   STHING: foreach $s (@some) {
3383         my $obj;
3384         if (ref $s) {
3385             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3386             $obj = $s;
3387         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3388         } elsif ($s =~ m|^/|) { # looks like a regexp
3389             if (substr($s,-1,1) eq ".") {
3390                 $obj = CPAN::Shell->expandany($s);
3391             } else {
3392                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3393                                         "not supported.\nRejecting argument '$s'\n");
3394                 $CPAN::Frontend->mysleep(2);
3395                 next;
3396             }
3397         } elsif ($meth eq "ls") {
3398             $self->globls($s,\@pragma);
3399             next STHING;
3400         } else {
3401             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3402             $obj = CPAN::Shell->expandany($s);
3403         }
3404         if (0) {
3405         } elsif (ref $obj) {
3406             if ($meth =~ /^($needs_recursion_protection)$/) {
3407                 # it would be silly to check for recursion for look or dump
3408                 # (we are in CPAN::Shell::rematein)
3409                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3410                 eval {  $obj->color_cmd_tmps(0,1); };
3411                 if ($@) {
3412                     if (ref $@
3413                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3414                         $CPAN::Frontend->mywarn($@);
3415                     } else {
3416                         if (0) {
3417                             require Carp;
3418                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3419                         }
3420                         die;
3421                     }
3422                 }
3423             }
3424             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3425             push @qcopy, $obj;
3426         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3427             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3428             if ($meth =~ /^(dump|ls|reports)$/) {
3429                 $obj->$meth();
3430             } else {
3431                 $CPAN::Frontend->mywarn(
3432                                         join "",
3433                                         "Don't be silly, you can't $meth ",
3434                                         $obj->fullname,
3435                                         " ;-)\n"
3436                                        );
3437                 $CPAN::Frontend->mysleep(2);
3438             }
3439         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3440             CPAN::InfoObj->dump($s);
3441         } else {
3442             $CPAN::Frontend
3443                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3444                          qq{don't know what it is.
3445 Try the command
3446
3447     i /$s/
3448
3449 to find objects with matching identifiers.
3450 });
3451             $CPAN::Frontend->mysleep(2);
3452         }
3453     }
3454
3455     # queuerunner (please be warned: when I started to change the
3456     # queue to hold objects instead of names, I made one or two
3457     # mistakes and never found which. I reverted back instead)
3458   QITEM: while (my $q = CPAN::Queue->first) {
3459         my $obj;
3460         my $s = $q->as_string;
3461         my $reqtype = $q->reqtype || "";
3462         $obj = CPAN::Shell->expandany($s);
3463         unless ($obj) {
3464             # don't know how this can happen, maybe we should panic,
3465             # but maybe we get a solution from the first user who hits
3466             # this unfortunate exception?
3467             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3468                                     "to an object. Skipping.\n");
3469             $CPAN::Frontend->mysleep(5);
3470             CPAN::Queue->delete_first($s);
3471             next QITEM;
3472         }
3473         $obj->{reqtype} ||= "";
3474         {
3475             # force debugging because CPAN::SQLite somehow delivers us
3476             # an empty object;
3477
3478             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3479
3480             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3481                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3482         }
3483         if ($obj->{reqtype}) {
3484             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3485                 $obj->{reqtype} = $reqtype;
3486                 if (
3487                     exists $obj->{install}
3488                     &&
3489                     (
3490                      UNIVERSAL::can($obj->{install},"failed") ?
3491                      $obj->{install}->failed :
3492                      $obj->{install} =~ /^NO/
3493                     )
3494                    ) {
3495                     delete $obj->{install};
3496                     $CPAN::Frontend->mywarn
3497                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3498                 }
3499             }
3500         } else {
3501             $obj->{reqtype} = $reqtype;
3502         }
3503
3504         for my $pragma (@pragma) {
3505             if ($pragma
3506                 &&
3507                 $obj->can($pragma)) {
3508                 $obj->$pragma($meth);
3509             }
3510         }
3511         if (UNIVERSAL::can($obj, 'called_for')) {
3512             $obj->called_for($s);
3513         }
3514         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3515                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3516
3517         push @qcopy, $obj;
3518         if ($meth =~ /^(report)$/) { # they came here with a pragma?
3519             $self->$meth($obj);
3520         } elsif (! UNIVERSAL::can($obj,$meth)) {
3521             # Must never happen
3522             my $serialized = "";
3523             if (0) {
3524             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3525                 $serialized = YAML::Syck::Dump($obj);
3526             } elsif ($CPAN::META->has_inst("YAML")) {
3527                 $serialized = YAML::Dump($obj);
3528             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3529                 $serialized = Data::Dumper::Dumper($obj);
3530             } else {
3531                 require overload;
3532                 $serialized = overload::StrVal($obj);
3533             }
3534             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3535             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3536         } elsif ($obj->$meth()) {
3537             CPAN::Queue->delete($s);
3538             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3539         } else {
3540             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3541         }
3542
3543         $obj->undelay;
3544         for my $pragma (@pragma) {
3545             my $unpragma = "un$pragma";
3546             if ($obj->can($unpragma)) {
3547                 $obj->$unpragma();
3548             }
3549         }
3550         if ($CPAN::Config->{halt_on_failure}
3551                 &&
3552                     CPAN::Distrostatus::something_has_just_failed()
3553               ) {
3554             $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
3555             CPAN::Queue->nullify_queue;
3556             last QITEM;
3557         }
3558         CPAN::Queue->delete_first($s);
3559     }
3560     if ($meth =~ /^($needs_recursion_protection)$/) {
3561         for my $obj (@qcopy) {
3562             $obj->color_cmd_tmps(0,0);
3563         }
3564     }
3565 }
3566
3567 #-> sub CPAN::Shell::recent ;
3568 sub recent {
3569   my($self) = @_;
3570   if ($CPAN::META->has_inst("XML::LibXML")) {
3571       my $url = $CPAN::Defaultrecent;
3572       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3573       unless ($CPAN::META->has_usable("LWP")) {
3574           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3575       }
3576       CPAN::LWP::UserAgent->config;
3577       my $Ua;
3578       eval { $Ua = CPAN::LWP::UserAgent->new; };
3579       if ($@) {
3580           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3581       }
3582       my $resp = $Ua->get($url);
3583       unless ($resp->is_success) {
3584           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3585       }
3586       $CPAN::Frontend->myprint("DONE\n\n");
3587       my $xml = XML::LibXML->new->parse_string($resp->content);
3588       if (0) {
3589           my $s = $xml->serialize(2);
3590           $s =~ s/\n\s*\n/\n/g;
3591           $CPAN::Frontend->myprint($s);
3592           return;
3593       }
3594       my @distros;
3595       if ($url =~ /winnipeg/) {
3596           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3597           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3598           for my $eitem ($xml->findnodes("/rss/channel/item")) {
3599               my $distro = $eitem->findvalue("enclosure/\@url");
3600               $distro =~ s|.*?/authors/id/./../||;
3601               my $size   = $eitem->findvalue("enclosure/\@length");
3602               my $desc   = $eitem->findvalue("description");
3603               $desc =~ s/.+? - //;
3604               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3605               push @distros, $distro;
3606           }
3607       } elsif ($url =~ /search.*uploads.rdf/) {
3608           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3609           # xmlns="http://purl.org/rss/1.0/"
3610           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3611           # xmlns:dc="http://purl.org/dc/elements/1.1/"
3612           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3613           # xmlns:admin="http://webns.net/mvcb/"
3614
3615
3616           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3617           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3618           my $finish_eitem = 0;
3619           local $SIG{INT} = sub { $finish_eitem = 1 };
3620         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3621               my $distro = $eitem->findvalue("\@rdf:about");
3622               $distro =~ s|.*~||; # remove up to the tilde before the name
3623               $distro =~ s|/$||; # remove trailing slash
3624               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3625               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3626               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3627               my $i = 0;
3628             SUBDIRTEST: while () {
3629                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3630                   if (my @ret = $self->globls("$distro*")) {
3631                       @ret = grep {$_->[2] !~ /meta/} @ret;
3632                       @ret = grep {length $_->[2]} @ret;
3633                       if (@ret) {
3634                           $distro = "$author/$ret[0][2]";
3635                           last SUBDIRTEST;
3636                       }
3637                   }
3638                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3639               }
3640
3641               next EITEM if $distro =~ m|\*|; # did not find the thing
3642               $CPAN::Frontend->myprint("____$desc\n");
3643               push @distros, $distro;
3644               last EITEM if $finish_eitem;
3645           }
3646       }
3647       return \@distros;
3648   } else {
3649       # deprecated old version
3650       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3651   }
3652 }
3653
3654 #-> sub CPAN::Shell::smoke ;
3655 sub smoke {
3656     my($self) = @_;
3657     my $distros = $self->recent;
3658   DISTRO: for my $distro (@$distros) {
3659         next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
3660         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3661         {
3662             my $skip = 0;
3663             local $SIG{INT} = sub { $skip = 1 };
3664             for (0..9) {
3665                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3666                 sleep 1;
3667                 if ($skip) {
3668                     $CPAN::Frontend->myprint(" skipped\n");
3669                     next DISTRO;
3670                 }
3671             }
3672         }
3673         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3674         $self->test($distro);
3675     }
3676 }
3677
3678 {
3679     # set up the dispatching methods
3680     no strict "refs";
3681     for my $command (qw(
3682                         clean
3683                         cvs_import
3684                         dump
3685                         force
3686                         fforce
3687                         get
3688                         install
3689                         look
3690                         ls
3691                         make
3692                         notest
3693                         perldoc
3694                         readme
3695                         reports
3696                         test
3697                        )) {
3698         *$command = sub { shift->rematein($command, @_); };
3699     }
3700 }
3701
3702 package CPAN::LWP::UserAgent;
3703 use strict;
3704
3705 sub config {
3706     return if $SETUPDONE;
3707     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3708         require LWP::UserAgent;
3709         @ISA = qw(Exporter LWP::UserAgent);
3710         $SETUPDONE++;
3711     } else {
3712         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3713     }
3714 }
3715
3716 sub get_basic_credentials {
3717     my($self, $realm, $uri, $proxy) = @_;
3718     if ($USER && $PASSWD) {
3719         return ($USER, $PASSWD);
3720     }
3721     if ( $proxy ) {
3722         ($USER,$PASSWD) = $self->get_proxy_credentials();
3723     } else {
3724         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3725     }
3726     return($USER,$PASSWD);
3727 }
3728
3729 sub get_proxy_credentials {
3730     my $self = shift;
3731     my ($user, $password);
3732     if ( defined $CPAN::Config->{proxy_user} ) {
3733         $user = $CPAN::Config->{proxy_user};
3734         $password = $CPAN::Config->{proxy_pass} || "";
3735         return ($user, $password);
3736     }
3737     my $username_prompt = "\nProxy authentication needed!
3738  (Note: to permanently configure username and password run
3739    o conf proxy_user your_username
3740    o conf proxy_pass your_password
3741      )\nUsername:";
3742     ($user, $password) =
3743         _get_username_and_password_from_user($username_prompt);
3744     return ($user,$password);
3745 }
3746
3747 sub get_non_proxy_credentials {
3748     my $self = shift;
3749     my ($user,$password);
3750     if ( defined $CPAN::Config->{username} ) {
3751         $user = $CPAN::Config->{username};
3752         $password = $CPAN::Config->{password} || "";
3753         return ($user, $password);
3754     }
3755     my $username_prompt = "\nAuthentication needed!
3756      (Note: to permanently configure username and password run
3757        o conf username your_username
3758        o conf password your_password
3759      )\nUsername:";
3760
3761     ($user, $password) =
3762         _get_username_and_password_from_user($username_prompt);
3763     return ($user,$password);
3764 }
3765
3766 sub _get_username_and_password_from_user {
3767     my $username_message = shift;
3768     my ($username,$password);
3769
3770     ExtUtils::MakeMaker->import(qw(prompt));
3771     $username = prompt($username_message);
3772         if ($CPAN::META->has_inst("Term::ReadKey")) {
3773             Term::ReadKey::ReadMode("noecho");
3774         }
3775     else {
3776         $CPAN::Frontend->mywarn(
3777             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3778         );
3779     }
3780     $password = prompt("Password:");
3781
3782         if ($CPAN::META->has_inst("Term::ReadKey")) {
3783             Term::ReadKey::ReadMode("restore");
3784         }
3785         $CPAN::Frontend->myprint("\n\n");
3786     return ($username,$password);
3787 }
3788
3789 # mirror(): Its purpose is to deal with proxy authentication. When we
3790 # call SUPER::mirror, we relly call the mirror method in
3791 # LWP::UserAgent. LWP::UserAgent will then call
3792 # $self->get_basic_credentials or some equivalent and this will be
3793 # $self->dispatched to our own get_basic_credentials method.
3794
3795 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3796
3797 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3798 # although we have gone through our get_basic_credentials, the proxy
3799 # server refuses to connect. This could be a case where the username or
3800 # password has changed in the meantime, so I'm trying once again without
3801 # $USER and $PASSWD to give the get_basic_credentials routine another
3802 # chance to set $USER and $PASSWD.
3803
3804 # mirror(): Its purpose is to deal with proxy authentication. When we
3805 # call SUPER::mirror, we relly call the mirror method in
3806 # LWP::UserAgent. LWP::UserAgent will then call
3807 # $self->get_basic_credentials or some equivalent and this will be
3808 # $self->dispatched to our own get_basic_credentials method.
3809
3810 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3811
3812 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3813 # although we have gone through our get_basic_credentials, the proxy
3814 # server refuses to connect. This could be a case where the username or
3815 # password has changed in the meantime, so I'm trying once again without
3816 # $USER and $PASSWD to give the get_basic_credentials routine another
3817 # chance to set $USER and $PASSWD.
3818
3819 sub mirror {
3820     my($self,$url,$aslocal) = @_;
3821     my $result = $self->SUPER::mirror($url,$aslocal);
3822     if ($result->code == 407) {
3823         undef $USER;
3824         undef $PASSWD;
3825         $result = $self->SUPER::mirror($url,$aslocal);
3826     }
3827     $result;
3828 }
3829
3830 package CPAN::FTP;
3831 use strict;
3832
3833 #-> sub CPAN::FTP::ftp_statistics
3834 # if they want to rewrite, they need to pass in a filehandle
3835 sub _ftp_statistics {
3836     my($self,$fh) = @_;
3837     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3838     $fh ||= FileHandle->new;
3839     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3840     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3841     my $sleep = 1;
3842     my $waitstart;
3843     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3844         $waitstart ||= localtime();
3845         if ($sleep>3) {
3846             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3847         }
3848         $CPAN::Frontend->mysleep($sleep);
3849         if ($sleep <= 3) {
3850             $sleep+=0.33;
3851         } elsif ($sleep <=6) {
3852             $sleep+=0.11;
3853         }
3854     }
3855     my $stats = eval { CPAN->_yaml_loadfile($file); };
3856     if ($@) {
3857         if (ref $@) {
3858             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3859                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3860                 return;
3861             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3862                 $CPAN::Frontend->mydie($@);
3863             }
3864         } else {
3865             $CPAN::Frontend->mydie($@);
3866         }
3867     }
3868     return $stats->[0];
3869 }
3870
3871 #-> sub CPAN::FTP::_mytime
3872 sub _mytime () {
3873     if (CPAN->has_inst("Time::HiRes")) {
3874         return Time::HiRes::time();
3875     } else {
3876         return time;
3877     }
3878 }
3879
3880 #-> sub CPAN::FTP::_new_stats
3881 sub _new_stats {
3882     my($self,$file) = @_;
3883     my $ret = {
3884                file => $file,
3885                attempts => [],
3886                start => _mytime,
3887               };
3888     $ret;
3889 }
3890
3891 #-> sub CPAN::FTP::_add_to_statistics
3892 sub _add_to_statistics {
3893     my($self,$stats) = @_;
3894     my $yaml_module = CPAN::_yaml_module;
3895     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3896     if ($CPAN::META->has_inst($yaml_module)) {
3897         $stats->{thesiteurl} = $ThesiteURL;
3898         $stats->{end} = CPAN::FTP::_mytime();
3899         my $fh = FileHandle->new;
3900         my $time = time;
3901         my $sdebug = 0;
3902         my @debug;
3903         @debug = $time if $sdebug;
3904         my $fullstats = $self->_ftp_statistics($fh);
3905         close $fh;
3906         $fullstats->{history} ||= [];
3907         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3908         push @debug, time if $sdebug;
3909         push @{$fullstats->{history}}, $stats;
3910         # YAML.pm 0.62 is unacceptably slow with 999;
3911         # YAML::Syck 0.82 has no noticable performance problem with 999;
3912         my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
3913         my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
3914         while (
3915                @{$fullstats->{history}} > $ftpstats_size
3916                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
3917               ) {
3918             shift @{$fullstats->{history}}
3919         }
3920         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3921         push @debug, time if $sdebug;
3922         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3923         # need no eval because if this fails, it is serious
3924         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3925         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3926         if ( $sdebug ) {
3927             local $CPAN::DEBUG = 512; # FTP
3928             push @debug, time;
3929             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3930                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3931                                 @debug,
3932                                ));
3933         }
3934         # Win32 cannot rename a file to an existing filename
3935         unlink($sfile) if ($^O eq 'MSWin32');
3936         _copy_stat($sfile, "$sfile.$$") if -e $sfile;
3937         rename "$sfile.$$", $sfile
3938             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3939     }
3940 }
3941
3942 # Copy some stat information (owner, group, mode and) from one file to
3943 # another.
3944 # This is a utility function which might be moved to a utility repository.
3945 #-> sub CPAN::FTP::_copy_stat
3946 sub _copy_stat {
3947     my($src, $dest) = @_;
3948     my @stat = stat($src);
3949     if (!@stat) {
3950         $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
3951         return;
3952     }
3953
3954     eval {
3955         chmod $stat[2], $dest
3956             or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
3957     };
3958     warn $@ if $@;
3959     eval {
3960         chown $stat[4], $stat[5], $dest
3961             or do {
3962                 my $save_err = $!; # otherwise it's lost in the get... calls
3963                 $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
3964                                         (getpwuid($stat[4]))[0] . "/" .
3965                                         (getgrgid($stat[5]))[0] . ": $save_err\n"
3966                                        );
3967             };
3968     };
3969     warn $@ if $@;
3970 }
3971
3972 # if file is CHECKSUMS, suggest the place where we got the file to be
3973 # checked from, maybe only for young files?
3974 #-> sub CPAN::FTP::_recommend_url_for
3975 sub _recommend_url_for {
3976     my($self, $file) = @_;
3977     my $urllist = $self->_get_urllist;
3978     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3979         my $fullstats = $self->_ftp_statistics();
3980         my $history = $fullstats->{history} || [];
3981         while (my $last = pop @$history) {
3982             last if $last->{end} - time > 3600; # only young results are interesting
3983             next unless $last->{file}; # dirname of nothing dies!
3984             next unless $file eq File::Basename::dirname($last->{file});
3985             return $last->{thesiteurl};
3986         }
3987     }
3988     if ($CPAN::Config->{randomize_urllist}
3989         &&
3990         rand(1) < $CPAN::Config->{randomize_urllist}
3991        ) {
3992         $urllist->[int rand scalar @$urllist];
3993     } else {
3994         return ();
3995     }
3996 }
3997
3998 #-> sub CPAN::FTP::_get_urllist
3999 sub _get_urllist {
4000     my($self) = @_;
4001     $CPAN::Config->{urllist} ||= [];
4002     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
4003         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
4004         $CPAN::Config->{urllist} = [];
4005     }
4006     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
4007     for my $u (@urllist) {
4008         CPAN->debug("u[$u]") if $CPAN::DEBUG;
4009         if (UNIVERSAL::can($u,"text")) {
4010             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
4011         } else {
4012             $u .= "/" unless substr($u,-1) eq "/";
4013             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
4014         }
4015     }
4016     \@urllist;
4017 }
4018
4019 #-> sub CPAN::FTP::ftp_get ;
4020 sub ftp_get {
4021     my($class,$host,$dir,$file,$target) = @_;
4022     $class->debug(
4023                   qq[Going to fetch file [$file] from dir [$dir]
4024         on host [$host] as local [$target]\n]
4025                  ) if $CPAN::DEBUG;
4026     my $ftp = Net::FTP->new($host);
4027     unless ($ftp) {
4028         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
4029         return;
4030     }
4031     return 0 unless defined $ftp;
4032     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
4033     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
4034     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
4035         my $msg = $ftp->message;
4036         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
4037         return;
4038     }
4039     unless ( $ftp->cwd($dir) ) {
4040         my $msg = $ftp->message;
4041         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
4042         return;
4043     }
4044     $ftp->binary;
4045     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
4046     unless ( $ftp->get($file,$target) ) {
4047         my $msg = $ftp->message;
4048         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
4049         return;
4050     }
4051     $ftp->quit; # it's ok if this fails
4052     return 1;
4053 }
4054
4055 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
4056
4057  # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
4058  # > --- /tmp/cp Wed Sep 24 13:26:40 1997
4059  # > ***************
4060  # > *** 1562,1567 ****
4061  # > --- 1562,1580 ----
4062  # >       return 1 if substr($url,0,4) eq "file";
4063  # >       return 1 unless $url =~ m|://([^/]+)|;
4064  # >       my $host = $1;
4065  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4066  # > +     if ($proxy) {
4067  # > +         $proxy =~ m|://([^/:]+)|;
4068  # > +         $proxy = $1;
4069  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
4070  # > +         if ($noproxy) {
4071  # > +             if ($host !~ /$noproxy$/) {
4072  # > +                 $host = $proxy;
4073  # > +             }
4074  # > +         } else {
4075  # > +             $host = $proxy;
4076  # > +         }
4077  # > +     }
4078  # >       require Net::Ping;
4079  # >       return 1 unless $Net::Ping::VERSION >= 2;
4080  # >       my $p;
4081
4082
4083 #-> sub CPAN::FTP::localize ;
4084 sub localize {
4085     my($self,$file,$aslocal,$force) = @_;
4086     $force ||= 0;
4087     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
4088         unless defined $aslocal;
4089     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
4090         if $CPAN::DEBUG;
4091
4092     if ($^O eq 'MacOS') {
4093         # Comment by AK on 2000-09-03: Uniq short filenames would be
4094         # available in CHECKSUMS file
4095         my($name, $path) = File::Basename::fileparse($aslocal, '');
4096         if (length($name) > 31) {
4097             $name =~ s/(
4098                         \.(
4099                            readme(\.(gz|Z))? |
4100                            (tar\.)?(gz|Z) |
4101                            tgz |
4102                            zip |
4103                            pm\.(gz|Z)
4104                           )
4105                        )$//x;
4106             my $suf = $1;
4107             my $size = 31 - length($suf);
4108             while (length($name) > $size) {
4109                 chop $name;
4110             }
4111             $name .= $suf;
4112             $aslocal = File::Spec->catfile($path, $name);
4113         }
4114     }
4115
4116     if (-f $aslocal && -r _ && !($force & 1)) {
4117         my $size;
4118         if ($size = -s $aslocal) {
4119             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
4120             return $aslocal;
4121         } else {
4122             # empty file from a previous unsuccessful attempt to download it
4123             unlink $aslocal or
4124                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
4125                                        "could not remove.");
4126         }
4127     }
4128     my($maybe_restore) = 0;
4129     if (-f $aslocal) {
4130         rename $aslocal, "$aslocal.bak$$";
4131         $maybe_restore++;
4132     }
4133
4134     my($aslocal_dir) = File::Basename::dirname($aslocal);
4135     $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
4136     # Inheritance is not easier to manage than a few if/else branches
4137     if ($CPAN::META->has_usable('LWP::UserAgent')) {
4138         unless ($Ua) {
4139             CPAN::LWP::UserAgent->config;
4140             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
4141             if ($@) {
4142                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
4143                     if $CPAN::DEBUG;
4144             } else {
4145                 my($var);
4146                 $Ua->proxy('ftp',  $var)
4147                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
4148                 $Ua->proxy('http', $var)
4149                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4150                 $Ua->no_proxy($var)
4151                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4152             }
4153         }
4154     }
4155     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
4156         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
4157     }
4158
4159     # Try the list of urls for each single object. We keep a record
4160     # where we did get a file from
4161     my(@reordered,$last);
4162     my $ccurllist = $self->_get_urllist;
4163     $last = $#$ccurllist;
4164     if ($force & 2) { # local cpans probably out of date, don't reorder
4165         @reordered = (0..$last);
4166     } else {
4167         @reordered =
4168             sort {
4169                 (substr($ccurllist->[$b],0,4) eq "file")
4170                     <=>
4171                 (substr($ccurllist->[$a],0,4) eq "file")
4172                     or
4173                 defined($ThesiteURL)
4174                     and
4175                 ($ccurllist->[$b] eq $ThesiteURL)
4176                     <=>
4177                 ($ccurllist->[$a] eq $ThesiteURL)
4178             } 0..$last;
4179     }
4180     my(@levels);
4181     $Themethod ||= "";
4182     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
4183     my @all_levels = (
4184                       ["dleasy",   "file"],
4185                       ["dleasy"],
4186                       ["dlhard"],
4187                       ["dlhardest"],
4188                       ["dleasy",   "http","defaultsites"],
4189                       ["dlhard",   "http","defaultsites"],
4190                       ["dleasy",   "ftp", "defaultsites"],
4191                       ["dlhard",   "ftp", "defaultsites"],
4192                       ["dlhardest","",    "defaultsites"],
4193                      );
4194     if ($Themethod) {
4195         @levels = grep {$_->[0] eq $Themethod} @all_levels;
4196         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4197     } else {
4198         @levels = @all_levels;
4199     }
4200     @levels = qw/dleasy/ if $^O eq 'MacOS';
4201     my($levelno);
4202     local $ENV{FTP_PASSIVE} =
4203         exists $CPAN::Config->{ftp_passive} ?
4204         $CPAN::Config->{ftp_passive} : 1;
4205     my $ret;
4206     my $stats = $self->_new_stats($file);
4207     for ($CPAN::Config->{connect_to_internet_ok}) {
4208         $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
4209     }
4210   LEVEL: for $levelno (0..$#levels) {
4211         my $level_tuple = $levels[$levelno];
4212         my($level,$scheme,$sitetag) = @$level_tuple;
4213         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4214         my @urllist;
4215         if ($defaultsites) {
4216             unless (defined $connect_to_internet_ok) {
4217                 $CPAN::Frontend->myprint(sprintf qq{
4218 I would like to connect to one of the following sites to get '%s':
4219
4220 %s
4221 },
4222                                          $file,
4223                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4224                                         );
4225                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4226                 if ($answer =~ /^y/i) {
4227                     $connect_to_internet_ok = 1;
4228                 } else {
4229                     $connect_to_internet_ok = 0;
4230                 }
4231             }
4232             if ($connect_to_internet_ok) {
4233                 @urllist = @CPAN::Defaultsites;
4234             } else {
4235                 my $sleep = 5;
4236                 $CPAN::Frontend->mywarn(sprintf qq{
4237
4238 You have not configured a urllist and did not allow to connect to the
4239 internet. I will continue but it is very likely that we will face
4240 problems. If this happens, please consider to call either
4241
4242     o conf init connect_to_internet_ok
4243 or
4244     o conf init urllist
4245
4246 Sleeping $sleep seconds now.
4247 });
4248                 $CPAN::Frontend->mysleep($sleep);
4249                 @urllist = ();
4250             }
4251         } else {
4252             my @host_seq = $level =~ /dleasy/ ?
4253                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4254             @urllist = map { $ccurllist->[$_] } @host_seq;
4255         }
4256         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4257         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4258         if (my $recommend = $self->_recommend_url_for($file)) {
4259             @urllist = grep { $_ ne $recommend } @urllist;
4260             unshift @urllist, $recommend;
4261         }
4262         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4263         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4264         if ($ret) {
4265             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4266             if ($ret eq $aslocal_tempfile) {
4267                 # if we got it exactly as we asked for, only then we
4268                 # want to rename
4269                 rename $aslocal_tempfile, $aslocal
4270                     or $CPAN::Frontend->mydie("Error while trying to rename ".
4271                                               "'$ret' to '$aslocal': $!");
4272                 $ret = $aslocal;
4273             }
4274             $Themethod = $level;
4275             my $now = time;
4276             # utime $now, $now, $aslocal; # too bad, if we do that, we
4277                                           # might alter a local mirror
4278             $self->debug("level[$level]") if $CPAN::DEBUG;
4279             last LEVEL;
4280         } else {
4281             unlink $aslocal_tempfile;
4282             last if $CPAN::Signal; # need to cleanup
4283         }
4284     }
4285     if ($ret) {
4286         $stats->{filesize} = -s $ret;
4287     }
4288     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4289     $self->_add_to_statistics($stats);
4290     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4291     if ($ret) {
4292         unlink "$aslocal.bak$$";
4293         return $ret;
4294     }
4295     unless ($CPAN::Signal) {
4296         my(@mess);
4297         local $" = " ";
4298         if (@{$CPAN::Config->{urllist}}) {
4299             push @mess,
4300                 qq{Please check, if the URLs I found in your configuration file \(}.
4301                     join(", ", @{$CPAN::Config->{urllist}}).
4302                         qq{\) are valid.};
4303         } else {
4304             push @mess, qq{Your urllist is empty!};
4305         }
4306         push @mess, qq{The urllist can be edited.},
4307             qq{E.g. with 'o conf urllist push ftp://myurl/'};
4308         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4309         $CPAN::Frontend->mywarn("Could not fetch $file\n");
4310         $CPAN::Frontend->mysleep(2);
4311     }
4312     if ($maybe_restore) {
4313         rename "$aslocal.bak$$", $aslocal;
4314         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4315                                  $self->ls($aslocal));
4316         return $aslocal;
4317     }
4318     return;
4319 }
4320
4321 sub mymkpath {
4322     my($self, $aslocal_dir) = @_;
4323     File::Path::mkpath($aslocal_dir);
4324     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4325                             qq{directory "$aslocal_dir".
4326     I\'ll continue, but if you encounter problems, they may be due
4327     to insufficient permissions.\n}) unless -w $aslocal_dir;
4328 }
4329
4330 sub hostdlxxx {
4331     my $self = shift;
4332     my $level = shift;
4333     my $scheme = shift;
4334     my $h = shift;
4335     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4336     my $method = "host$level";
4337     $self->$method($h, @_);
4338 }
4339
4340 sub _set_attempt {
4341     my($self,$stats,$method,$url) = @_;
4342     push @{$stats->{attempts}}, {
4343                                  method => $method,
4344                                  start => _mytime,
4345                                  url => $url,
4346                                 };
4347 }
4348
4349 # package CPAN::FTP;
4350 sub hostdleasy {
4351     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4352     my($ro_url);
4353   HOSTEASY: for $ro_url (@$host_seq) {
4354         $self->_set_attempt($stats,"dleasy",$ro_url);
4355         my $url .= "$ro_url$file";
4356         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4357         if ($url =~ /^file:/) {
4358             my $l;
4359             if ($CPAN::META->has_inst('URI::URL')) {
4360                 my $u =  URI::URL->new($url);
4361                 $l = $u->path;
4362             } else { # works only on Unix, is poorly constructed, but
4363                 # hopefully better than nothing.
4364                 # RFC 1738 says fileurl BNF is
4365                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4366                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4367                 # the code
4368                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4369                 $l =~ s|^file:||;                   # assume they
4370                                                     # meant
4371                                                     # file://localhost
4372                 $l =~ s|^/||s
4373                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4374             }
4375             $self->debug("local file[$l]") if $CPAN::DEBUG;
4376             if ( -f $l && -r _) {
4377                 $ThesiteURL = $ro_url;
4378                 return $l;
4379             }
4380             if ($l =~ /(.+)\.gz$/) {
4381                 my $ungz = $1;
4382                 if ( -f $ungz && -r _) {
4383                     $ThesiteURL = $ro_url;
4384                     return $ungz;
4385                 }
4386             }
4387             # Maybe mirror has compressed it?
4388             if (-f "$l.gz") {
4389                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4390                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4391                 if ( -f $aslocal) {
4392                     $ThesiteURL = $ro_url;
4393                     return $aslocal;
4394                 }
4395             }
4396             $CPAN::Frontend->mywarn("Could not find '$l'\n");
4397         }
4398         $self->debug("it was not a file URL") if $CPAN::DEBUG;
4399         if ($CPAN::META->has_usable('LWP')) {
4400             $CPAN::Frontend->myprint("Fetching with LWP:
4401   $url
4402 ");
4403             unless ($Ua) {
4404                 CPAN::LWP::UserAgent->config;
4405                 eval { $Ua = CPAN::LWP::UserAgent->new; };
4406                 if ($@) {
4407                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4408                 }
4409             }
4410             my $res = $Ua->mirror($url, $aslocal);
4411             if ($res->is_success) {
4412                 $ThesiteURL = $ro_url;
4413                 my $now = time;
4414                 utime $now, $now, $aslocal; # download time is more
4415                                             # important than upload
4416                                             # time
4417                 return $aslocal;
4418             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4419                 my $gzurl = "$url.gz";
4420                 $CPAN::Frontend->myprint("Fetching with LWP:
4421   $gzurl
4422 ");
4423                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4424                 if ($res->is_success) {
4425                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4426                         $ThesiteURL = $ro_url;
4427                         return $aslocal;
4428                     }
4429                 }
4430             } else {
4431                 $CPAN::Frontend->myprint(sprintf(
4432                                                  "LWP failed with code[%s] message[%s]\n",
4433                                                  $res->code,
4434                                                  $res->message,
4435                                                 ));
4436                 # Alan Burlison informed me that in firewall environments
4437                 # Net::FTP can still succeed where LWP fails. So we do not
4438                 # skip Net::FTP anymore when LWP is available.
4439             }
4440         } else {
4441             $CPAN::Frontend->mywarn("  LWP not available\n");
4442         }
4443         return if $CPAN::Signal;
4444         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4445             # that's the nice and easy way thanks to Graham
4446             $self->debug("recognized ftp") if $CPAN::DEBUG;
4447             my($host,$dir,$getfile) = ($1,$2,$3);
4448             if ($CPAN::META->has_usable('Net::FTP')) {
4449                 $dir =~ s|/+|/|g;
4450                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4451   $url
4452 ");
4453                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4454                              "aslocal[$aslocal]") if $CPAN::DEBUG;
4455                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4456                     $ThesiteURL = $ro_url;
4457                     return $aslocal;
4458                 }
4459                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4460                     my $gz = "$aslocal.gz";
4461                     $CPAN::Frontend->myprint("Fetching with Net::FTP
4462   $url.gz
4463 ");
4464                     if (CPAN::FTP->ftp_get($host,
4465                                            $dir,
4466                                            "$getfile.gz",
4467                                            $gz) &&
4468                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4469                     ) {
4470                         $ThesiteURL = $ro_url;
4471                         return $aslocal;
4472                     }
4473                 }
4474                 # next HOSTEASY;
4475             } else {
4476                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4477             }
4478         }
4479         if (
4480             UNIVERSAL::can($ro_url,"text")
4481             and
4482             $ro_url->{FROM} eq "USER"
4483            ) {
4484             ##address #17973: default URLs should not try to override
4485             ##user-defined URLs just because LWP is not available
4486             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4487             return $ret if $ret;
4488         }
4489         return if $CPAN::Signal;
4490     }
4491 }
4492
4493 # package CPAN::FTP;
4494 sub hostdlhard {
4495     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4496
4497     # Came back if Net::FTP couldn't establish connection (or
4498     # failed otherwise) Maybe they are behind a firewall, but they
4499     # gave us a socksified (or other) ftp program...
4500
4501     my($ro_url);
4502     my($devnull) = $CPAN::Config->{devnull} || "";
4503     # < /dev/null ";
4504     my($aslocal_dir) = File::Basename::dirname($aslocal);
4505     File::Path::mkpath($aslocal_dir);
4506   HOSTHARD: for $ro_url (@$host_seq) {
4507         $self->_set_attempt($stats,"dlhard",$ro_url);
4508         my $url = "$ro_url$file";
4509         my($proto,$host,$dir,$getfile);
4510
4511         # Courtesy Mark Conty mark_conty@cargill.com change from
4512         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4513         # to
4514         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4515             # proto not yet used
4516             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4517         } else {
4518             next HOSTHARD; # who said, we could ftp anything except ftp?
4519         }
4520         next HOSTHARD if $proto eq "file"; # file URLs would have had
4521                                            # success above. Likely a bogus URL
4522
4523         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4524
4525         # Try the most capable first and leave ncftp* for last as it only
4526         # does FTP.
4527         my $proxy_vars = $self->_proxy_vars($ro_url);
4528       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4529             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4530             next unless defined $funkyftp;
4531             next if $funkyftp =~ /^\s*$/;
4532
4533             my($asl_ungz, $asl_gz);
4534             ($asl_ungz = $aslocal) =~ s/\.gz//;
4535                 $asl_gz = "$asl_ungz.gz";
4536
4537             my($src_switch) = "";
4538             my($chdir) = "";
4539             my($stdout_redir) = " > $asl_ungz";
4540             if ($f eq "lynx") {
4541                 $src_switch = " -source";
4542             } elsif ($f eq "ncftp") {
4543                 $src_switch = " -c";
4544             } elsif ($f eq "wget") {
4545                 $src_switch = " -O $asl_ungz";
4546                 $stdout_redir = "";
4547             } elsif ($f eq 'curl') {
4548                 $src_switch = ' -L -f -s -S --netrc-optional';
4549                 if ($proxy_vars->{http_proxy}) {
4550                     $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
4551                 }
4552             }
4553
4554             if ($f eq "ncftpget") {
4555                 $chdir = "cd $aslocal_dir && ";
4556                 $stdout_redir = "";
4557             }
4558             $CPAN::Frontend->myprint(
4559                                      qq[
4560 Trying with "$funkyftp$src_switch" to get
4561     $url
4562 ]);
4563             my($system) =
4564                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4565             $self->debug("system[$system]") if $CPAN::DEBUG;
4566             my($wstatus) = system($system);
4567             if ($f eq "lynx") {
4568                 # lynx returns 0 when it fails somewhere
4569                 if (-s $asl_ungz) {
4570                     my $content = do { local *FH;
4571                                        open FH, $asl_ungz or die;
4572                                        local $/;
4573                                        <FH> };
4574                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4575                         $CPAN::Frontend->mywarn(qq{
4576 No success, the file that lynx has downloaded looks like an error message:
4577 $content
4578 });
4579                         $CPAN::Frontend->mysleep(1);
4580                         next DLPRG;
4581                     }
4582                 } else {
4583                     $CPAN::Frontend->myprint(qq{
4584 No success, the file that lynx has downloaded is an empty file.
4585 });
4586                     next DLPRG;
4587                 }
4588             }
4589             if ($wstatus == 0) {
4590                 if (-s $aslocal) {
4591                     # Looks good
4592                 } elsif ($asl_ungz ne $aslocal) {
4593                     # test gzip integrity
4594                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4595                         # e.g. foo.tar is gzipped --> foo.tar.gz
4596                         rename $asl_ungz, $aslocal;
4597                     } else {
4598                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4599                     }
4600                 }
4601                 $ThesiteURL = $ro_url;
4602                 return $aslocal;
4603             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4604                 unlink $asl_ungz if
4605                     -f $asl_ungz && -s _ == 0;
4606                 my $gz = "$aslocal.gz";
4607                 my $gzurl = "$url.gz";
4608                 $CPAN::Frontend->myprint(
4609                                         qq[
4610     Trying with "$funkyftp$src_switch" to get
4611     $url.gz
4612     ]);
4613                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4614                 $self->debug("system[$system]") if $CPAN::DEBUG;
4615                 my($wstatus);
4616                 if (($wstatus = system($system)) == 0
4617                     &&
4618                     -s $asl_gz
4619                 ) {
4620                     # test gzip integrity
4621                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4622                     if ($ct && $ct->gtest) {
4623                         $ct->gunzip($aslocal);
4624                     } else {
4625                         # somebody uncompressed file for us?
4626                         rename $asl_ungz, $aslocal;
4627                     }
4628                     $ThesiteURL = $ro_url;
4629                     return $aslocal;
4630                 } else {
4631                     unlink $asl_gz if -f $asl_gz;
4632                 }
4633             } else {
4634                 my $estatus = $wstatus >> 8;
4635                 my $size = -f $aslocal ?
4636                     ", left\n$aslocal with size ".-s _ :
4637                     "\nWarning: expected file [$aslocal] doesn't exist";
4638                 $CPAN::Frontend->myprint(qq{
4639     System call "$system"
4640     returned status $estatus (wstat $wstatus)$size
4641     });
4642             }
4643             return if $CPAN::Signal;
4644         } # transfer programs
4645     } # host
4646 }
4647
4648 #-> CPAN::FTP::_proxy_vars
4649 sub _proxy_vars {
4650     my($self,$url) = @_;
4651     my $ret = +{};
4652     my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4653     if ($http_proxy) {
4654         my($host) = $url =~ m|://([^/:]+)|;
4655         my $want_proxy = 1;
4656         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
4657         my @noproxy = split /\s*,\s*/, $noproxy;
4658         if ($host) {
4659           DOMAIN: for my $domain (@noproxy) {
4660                 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
4661                     $want_proxy = 0;
4662                     last DOMAIN;
4663                 }
4664             }
4665         } else {
4666             $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
4667         }
4668         if ($want_proxy) {
4669             my($user, $pass) =
4670                 &CPAN::LWP::UserAgent::get_proxy_credentials();
4671             $ret = {
4672                     proxy_user => $user,
4673                     proxy_pass => $pass,
4674                     http_proxy => $http_proxy
4675                   };
4676         }
4677     }
4678     return $ret;
4679 }
4680
4681 # package CPAN::FTP;
4682 sub hostdlhardest {
4683     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4684
4685     return unless @$host_seq;
4686     my($ro_url);
4687     my($aslocal_dir) = File::Basename::dirname($aslocal);
4688     File::Path::mkpath($aslocal_dir);
4689     my $ftpbin = $CPAN::Config->{ftp};
4690     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4691         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4692         return;
4693     }
4694     $CPAN::Frontend->mywarn(qq{
4695 As a last ressort we now switch to the external ftp command '$ftpbin'
4696 to get '$aslocal'.
4697
4698 Doing so often leads to problems that are hard to diagnose.
4699
4700 If you're victim of such problems, please consider unsetting the ftp
4701 config variable with
4702
4703     o conf ftp ""
4704     o conf commit
4705
4706 });
4707     $CPAN::Frontend->mysleep(2);
4708   HOSTHARDEST: for $ro_url (@$host_seq) {
4709         $self->_set_attempt($stats,"dlhardest",$ro_url);
4710         my $url = "$ro_url$file";
4711         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4712         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4713             next;
4714         }
4715         my($host,$dir,$getfile) = ($1,$2,$3);
4716         my $timestamp = 0;
4717         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4718             $ctime,$blksize,$blocks) = stat($aslocal);
4719         $timestamp = $mtime ||= 0;
4720         my($netrc) = CPAN::FTP::netrc->new;
4721         my($netrcfile) = $netrc->netrc;
4722         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4723         my $targetfile = File::Basename::basename($aslocal);
4724         my(@dialog);
4725         push(
4726              @dialog,
4727              "lcd $aslocal_dir",
4728              "cd /",
4729              map("cd $_", split /\//, $dir), # RFC 1738
4730              "bin",
4731              "get $getfile $targetfile",
4732              "quit"
4733         );
4734         if (! $netrcfile) {
4735             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4736         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4737             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4738                                 $netrc->hasdefault,
4739                                 $netrc->contains($host))) if $CPAN::DEBUG;
4740             if ($netrc->protected) {
4741                 my $dialog = join "", map { "    $_\n" } @dialog;
4742                 my $netrc_explain;
4743                 if ($netrc->contains($host)) {
4744                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4745                         "manages the login";
4746                 } else {
4747                     $netrc_explain = "Relying that your default .netrc entry ".
4748                         "manages the login";
4749                 }
4750                 $CPAN::Frontend->myprint(qq{
4751   Trying with external ftp to get
4752     $url
4753   $netrc_explain
4754   Going to send the dialog
4755 $dialog
4756 }
4757                 );
4758                 $self->talk_ftp("$ftpbin$verbose $host",
4759                                 @dialog);
4760                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4761                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4762                 $mtime ||= 0;
4763                 if ($mtime > $timestamp) {
4764                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4765                     $ThesiteURL = $ro_url;
4766                     return $aslocal;
4767                 } else {
4768                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4769                 }
4770                     return if $CPAN::Signal;
4771             } else {
4772                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4773                                         qq{correctly protected.\n});
4774             }
4775         } else {
4776             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4777   nor does it have a default entry\n");
4778         }
4779
4780         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4781         # then and login manually to host, using e-mail as
4782         # password.
4783         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4784         unshift(
4785                 @dialog,
4786                 "open $host",
4787                 "user anonymous $Config::Config{'cf_email'}"
4788         );
4789         my $dialog = join "", map { "    $_\n" } @dialog;
4790         $CPAN::Frontend->myprint(qq{
4791   Trying with external ftp to get
4792     $url
4793   Going to send the dialog
4794 $dialog
4795 }
4796         );
4797         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4798         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4799             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4800         $mtime ||= 0;
4801         if ($mtime > $timestamp) {
4802             $CPAN::Frontend->myprint("GOT $aslocal\n");
4803             $ThesiteURL = $ro_url;
4804             return $aslocal;
4805         } else {
4806             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4807         }
4808         return if $CPAN::Signal;
4809         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4810         $CPAN::Frontend->mysleep(2);
4811     } # host
4812 }
4813
4814 # package CPAN::FTP;
4815 sub talk_ftp {
4816     my($self,$command,@dialog) = @_;
4817     my $fh = FileHandle->new;
4818     $fh->open("|$command") or die "Couldn't open ftp: $!";
4819     foreach (@dialog) { $fh->print("$_\n") }
4820     $fh->close; # Wait for process to complete
4821     my $wstatus = $?;
4822     my $estatus = $wstatus >> 8;
4823     $CPAN::Frontend->myprint(qq{
4824 Subprocess "|$command"
4825   returned status $estatus (wstat $wstatus)
4826 }) if $wstatus;
4827 }
4828
4829 # find2perl needs modularization, too, all the following is stolen
4830 # from there
4831 # CPAN::FTP::ls
4832 sub ls {
4833     my($self,$name) = @_;
4834     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4835      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4836
4837     my($perms,%user,%group);
4838     my $pname = $name;
4839
4840     if ($blocks) {
4841         $blocks = int(($blocks + 1) / 2);
4842     }
4843     else {
4844         $blocks = int(($sizemm + 1023) / 1024);
4845     }
4846
4847     if    (-f _) { $perms = '-'; }
4848     elsif (-d _) { $perms = 'd'; }
4849     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4850     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4851     elsif (-p _) { $perms = 'p'; }
4852     elsif (-S _) { $perms = 's'; }
4853     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4854
4855     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4856     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4857     my $tmpmode = $mode;
4858     my $tmp = $rwx[$tmpmode & 7];
4859     $tmpmode >>= 3;
4860     $tmp = $rwx[$tmpmode & 7] . $tmp;
4861     $tmpmode >>= 3;
4862     $tmp = $rwx[$tmpmode & 7] . $tmp;
4863     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4864     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4865     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4866     $perms .= $tmp;
4867
4868     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4869     my $group = $group{$gid} || $gid;
4870
4871     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4872     my($timeyear);
4873     my($moname) = $moname[$mon];
4874     if (-M _ > 365.25 / 2) {
4875         $timeyear = $year + 1900;
4876     }
4877     else {
4878         $timeyear = sprintf("%02d:%02d", $hour, $min);
4879     }
4880
4881     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4882              $ino,
4883                   $blocks,
4884                        $perms,
4885                              $nlink,
4886                                  $user,
4887                                       $group,
4888                                            $sizemm,
4889                                                $moname,
4890                                                   $mday,
4891                                                       $timeyear,
4892                                                           $pname;
4893 }
4894
4895 package CPAN::FTP::netrc;
4896 use strict;
4897
4898 # package CPAN::FTP::netrc;
4899 sub new {
4900     my($class) = @_;
4901     my $home = CPAN::HandleConfig::home;
4902     my $file = File::Spec->catfile($home,".netrc");
4903
4904     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4905        $atime,$mtime,$ctime,$blksize,$blocks)
4906         = stat($file);
4907     $mode ||= 0;
4908     my $protected = 0;
4909
4910     my($fh,@machines,$hasdefault);
4911     $hasdefault = 0;
4912     $fh = FileHandle->new or die "Could not create a filehandle";
4913
4914     if($fh->open($file)) {
4915         $protected = ($mode & 077) == 0;
4916         local($/) = "";
4917       NETRC: while (<$fh>) {
4918             my(@tokens) = split " ", $_;
4919           TOKEN: while (@tokens) {
4920                 my($t) = shift @tokens;
4921                 if ($t eq "default") {
4922                     $hasdefault++;
4923                     last NETRC;
4924                 }
4925                 last TOKEN if $t eq "macdef";
4926                 if ($t eq "machine") {
4927                     push @machines, shift @tokens;
4928                 }
4929             }
4930         }
4931     } else {
4932         $file = $hasdefault = $protected = "";
4933     }
4934
4935     bless {
4936         'mach' => [@machines],
4937         'netrc' => $file,
4938         'hasdefault' => $hasdefault,
4939         'protected' => $protected,
4940     }, $class;
4941 }
4942
4943 # CPAN::FTP::netrc::hasdefault;
4944 sub hasdefault { shift->{'hasdefault'} }
4945 sub netrc      { shift->{'netrc'}      }
4946 sub protected  { shift->{'protected'}  }
4947 sub contains {
4948     my($self,$mach) = @_;
4949     for ( @{$self->{'mach'}} ) {
4950         return 1 if $_ eq $mach;
4951     }
4952     return 0;
4953 }
4954
4955 package CPAN::Complete;
4956 use strict;
4957
4958 sub gnu_cpl {
4959     my($text, $line, $start, $end) = @_;
4960     my(@perlret) = cpl($text, $line, $start);
4961     # find longest common match. Can anybody show me how to peruse
4962     # T::R::Gnu to have this done automatically? Seems expensive.
4963     return () unless @perlret;
4964     my($newtext) = $text;
4965     for (my $i = length($text)+1;;$i++) {
4966         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4967         my $try = substr($perlret[0],0,$i);
4968         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4969         # warn "try[$try]tries[@tries]";
4970         if (@tries == @perlret) {
4971             $newtext = $try;
4972         } else {
4973             last;
4974         }
4975     }
4976     ($newtext,@perlret);
4977 }
4978
4979 #-> sub CPAN::Complete::cpl ;
4980 sub cpl {
4981     my($word,$line,$pos) = @_;
4982     $word ||= "";
4983     $line ||= "";
4984     $pos ||= 0;
4985     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4986     $line =~ s/^\s*//;
4987     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4988         $pos -= length($1);
4989     }
4990     my @return;
4991     if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4992         @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4993     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4994         @return = ();
4995     } elsif ($line =~ /^(a|ls)\s/) {
4996         @return = cplx('CPAN::Author',uc($word));
4997     } elsif ($line =~ /^b\s/) {
4998         CPAN::Shell->local_bundles;
4999         @return = cplx('CPAN::Bundle',$word);
5000     } elsif ($line =~ /^d\s/) {
5001         @return = cplx('CPAN::Distribution',$word);
5002     } elsif ($line =~ m/^(
5003                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
5004                          )\s/x ) {
5005         if ($word =~ /^Bundle::/) {
5006             CPAN::Shell->local_bundles;
5007         }
5008         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5009     } elsif ($line =~ /^i\s/) {
5010         @return = cpl_any($word);
5011     } elsif ($line =~ /^reload\s/) {
5012         @return = cpl_reload($word,$line,$pos);
5013     } elsif ($line =~ /^o\s/) {
5014         @return = cpl_option($word,$line,$pos);
5015     } elsif ($line =~ m/^\S+\s/ ) {
5016         # fallback for future commands and what we have forgotten above
5017         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5018     } else {
5019         @return = ();
5020     }
5021     return @return;
5022 }
5023
5024 #-> sub CPAN::Complete::cplx ;
5025 sub cplx {
5026     my($class, $word) = @_;
5027     if (CPAN::_sqlite_running) {
5028         $CPAN::SQLite->search($class, "^\Q$word\E");
5029     }
5030     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5031 }
5032
5033 #-> sub CPAN::Complete::cpl_any ;
5034 sub cpl_any {
5035     my($word) = shift;
5036     return (
5037             cplx('CPAN::Author',$word),
5038             cplx('CPAN::Bundle',$word),
5039             cplx('CPAN::Distribution',$word),
5040             cplx('CPAN::Module',$word),
5041            );
5042 }
5043
5044 #-> sub CPAN::Complete::cpl_reload ;
5045 sub cpl_reload {
5046     my($word,$line,$pos) = @_;
5047     $word ||= "";
5048     my(@words) = split " ", $line;
5049     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5050     my(@ok) = qw(cpan index);
5051     return @ok if @words == 1;
5052     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5053 }
5054
5055 #-> sub CPAN::Complete::cpl_option ;
5056 sub cpl_option {
5057     my($word,$line,$pos) = @_;
5058     $word ||= "";
5059     my(@words) = split " ", $line;
5060     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5061     my(@ok) = qw(conf debug);
5062     return @ok if @words == 1;
5063     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5064     if (0) {
5065     } elsif ($words[1] eq 'index') {
5066         return ();
5067     } elsif ($words[1] eq 'conf') {
5068         return CPAN::HandleConfig::cpl(@_);
5069     } elsif ($words[1] eq 'debug') {
5070         return sort grep /^\Q$word\E/i,
5071             sort keys %CPAN::DEBUG, 'all';
5072     }
5073 }
5074
5075 package CPAN::Index;
5076 use strict;
5077
5078 #-> sub CPAN::Index::force_reload ;
5079 sub force_reload {
5080     my($class) = @_;
5081     $CPAN::Index::LAST_TIME = 0;
5082     $class->reload(1);
5083 }
5084
5085 #-> sub CPAN::Index::reload ;
5086 sub reload {
5087     my($self,$force) = @_;
5088     my $time = time;
5089
5090     # XXX check if a newer one is available. (We currently read it
5091     # from time to time)
5092     for ($CPAN::Config->{index_expire}) {
5093         $_ = 0.001 unless $_ && $_ > 0.001;
5094     }
5095     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
5096         # debug here when CPAN doesn't seem to read the Metadata
5097         require Carp;
5098         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
5099     }
5100     unless ($CPAN::META->{PROTOCOL}) {
5101         $self->read_metadata_cache;
5102         $CPAN::META->{PROTOCOL} ||= "1.0";
5103     }
5104     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
5105         # warn "Setting last_time to 0";
5106         $LAST_TIME = 0; # No warning necessary
5107     }
5108     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
5109         and ! $force) {
5110         # called too often
5111         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
5112     } elsif (0) {
5113         # IFF we are developing, it helps to wipe out the memory
5114         # between reloads, otherwise it is not what a user expects.
5115         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
5116         $CPAN::META = CPAN->new;
5117     } else {
5118         my($debug,$t2);
5119         local $LAST_TIME = $time;
5120         local $CPAN::META->{PROTOCOL} = PROTOCOL;
5121
5122         my $needshort = $^O eq "dos";
5123
5124         $self->rd_authindex($self
5125                           ->reload_x(
5126                                      "authors/01mailrc.txt.gz",
5127                                      $needshort ?
5128                                      File::Spec->catfile('authors', '01mailrc.gz') :
5129                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
5130                                      $force));
5131         $t2 = time;
5132         $debug = "timing reading 01[".($t2 - $time)."]";
5133         $time = $t2;
5134         return if $CPAN::Signal; # this is sometimes lengthy
5135         $self->rd_modpacks($self
5136                          ->reload_x(
5137                                     "modules/02packages.details.txt.gz",
5138                                     $needshort ?
5139                                     File::Spec->catfile('modules', '02packag.gz') :
5140                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
5141                                     $force));
5142         $t2 = time;
5143         $debug .= "02[".($t2 - $time)."]";
5144         $time = $t2;
5145         return if $CPAN::Signal; # this is sometimes lengthy
5146         $self->rd_modlist($self
5147                         ->reload_x(
5148                                    "modules/03modlist.data.gz",
5149                                    $needshort ?
5150                                    File::Spec->catfile('modules', '03mlist.gz') :
5151                                    File::Spec->catfile('modules', '03modlist.data.gz'),
5152                                    $force));
5153         $self->write_metadata_cache;
5154         $t2 = time;
5155         $debug .= "03[".($t2 - $time)."]";
5156         $time = $t2;
5157         CPAN->debug($debug) if $CPAN::DEBUG;
5158     }
5159     if ($CPAN::Config->{build_dir_reuse}) {
5160         $self->reanimate_build_dir;
5161     }
5162     if (CPAN::_sqlite_running) {
5163         $CPAN::SQLite->reload(time => $time, force => $force)
5164             if not $LAST_TIME;
5165     }
5166     $LAST_TIME = $time;
5167     $CPAN::META->{PROTOCOL} = PROTOCOL;
5168 }
5169
5170 #-> sub CPAN::Index::reanimate_build_dir ;
5171 sub reanimate_build_dir {
5172     my($self) = @_;
5173     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
5174         return;
5175     }
5176     return if $HAVE_REANIMATED++;
5177     my $d = $CPAN::Config->{build_dir};
5178     my $dh = DirHandle->new;
5179     opendir $dh, $d or return; # does not exist
5180     my $dirent;
5181     my $i = 0;
5182     my $painted = 0;
5183     my $restored = 0;
5184     my @candidates = map { $_->[0] }
5185         sort { $b->[1] <=> $a->[1] }
5186             map { [ $_, -M File::Spec->catfile($d,$_) ] }
5187                 grep {/\.yml$/} readdir $dh;
5188     unless (@candidates) {
5189         $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
5190         return;
5191     }
5192     $CPAN::Frontend->myprint
5193         (sprintf("Going to read %d yaml file%s from %s/\n",
5194                  scalar @candidates,
5195                  @candidates==1 ? "" : "s",
5196                  $CPAN::Config->{build_dir}
5197                 ));
5198     my $start = CPAN::FTP::_mytime;
5199   DISTRO: for $i (0..$#candidates) {
5200         my $dirent = $candidates[$i];
5201         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
5202         if ($@) {
5203             warn "Error while parsing file '$dirent'; error: '$@'";
5204             next DISTRO;
5205         }
5206         my $c = $y->[0];
5207         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
5208             my $key = $c->{distribution}{ID};
5209             for my $k (keys %{$c->{distribution}}) {
5210                 if ($c->{distribution}{$k}
5211                     && ref $c->{distribution}{$k}
5212                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
5213                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
5214                 }
5215             }
5216
5217             #we tried to restore only if element already
5218             #exists; but then we do not work with metadata
5219             #turned off.
5220             my $do
5221                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
5222                     = $c->{distribution};
5223             for my $skipper (qw(
5224                                 badtestcnt
5225                                 configure_requires_later
5226                                 configure_requires_later_for
5227                                 force_update
5228                                 later
5229                                 later_for
5230                                 notest
5231                                 should_report
5232                                 sponsored_mods
5233                                 prefs
5234                                 negative_prefs_cache
5235                                )) {
5236                 delete $do->{$skipper};
5237             }
5238             if ($do->tested_ok_but_not_installed) {
5239                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
5240             }
5241             $restored++;
5242         }
5243         $i++;
5244         while (($painted/76) < ($i/@candidates)) {
5245             $CPAN::Frontend->myprint(".");
5246             $painted++;
5247         }
5248     }
5249     my $took = CPAN::FTP::_mytime - $start;
5250     $CPAN::Frontend->myprint(sprintf(
5251                                      "DONE\nRestored the state of %s (in %.4f secs)\n",
5252                                      $restored || "none",
5253                                      $took,
5254                                     ));
5255 }
5256
5257
5258 #-> sub CPAN::Index::reload_x ;
5259 sub reload_x {
5260     my($cl,$wanted,$localname,$force) = @_;
5261     $force |= 2; # means we're dealing with an index here
5262     CPAN::HandleConfig->load; # we should guarantee loading wherever
5263                               # we rely on Config XXX
5264     $localname ||= $wanted;
5265     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5266                                          $localname);
5267     if (
5268         -f $abs_wanted &&
5269         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5270         !($force & 1)
5271        ) {
5272         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5273         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5274                    qq{day$s. I\'ll use that.});
5275         return $abs_wanted;
5276     } else {
5277         $force |= 1; # means we're quite serious about it.
5278     }
5279     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5280 }
5281
5282 #-> sub CPAN::Index::rd_authindex ;
5283 sub rd_authindex {
5284     my($cl, $index_target) = @_;
5285     return unless defined $index_target;
5286     return if CPAN::_sqlite_running;
5287     my @lines;
5288     $CPAN::Frontend->myprint("Going to read $index_target\n");
5289     local(*FH);
5290     tie *FH, 'CPAN::Tarzip', $index_target;
5291     local($/) = "\n";
5292     local($_);
5293     push @lines, split /\012/ while <FH>;
5294     my $i = 0;
5295     my $painted = 0;
5296     foreach (@lines) {
5297         my($userid,$fullname,$email) =
5298             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5299         $fullname ||= $email;
5300         if ($userid && $fullname && $email) {
5301             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5302             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5303         } else {
5304             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5305         }
5306         $i++;
5307         while (($painted/76) < ($i/@lines)) {
5308             $CPAN::Frontend->myprint(".");
5309             $painted++;
5310         }
5311         return if $CPAN::Signal;
5312     }
5313     $CPAN::Frontend->myprint("DONE\n");
5314 }
5315
5316 sub userid {
5317   my($self,$dist) = @_;
5318   $dist = $self->{'id'} unless defined $dist;
5319   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5320   $ret;
5321 }
5322
5323 #-> sub CPAN::Index::rd_modpacks ;
5324 sub rd_modpacks {
5325     my($self, $index_target) = @_;
5326     return unless defined $index_target;
5327     return if CPAN::_sqlite_running;
5328     $CPAN::Frontend->myprint("Going to read $index_target\n");
5329     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5330     local $_;
5331     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5332     my $slurp = "";
5333     my $chunk;
5334     while (my $bytes = $fh->READ(\$chunk,8192)) {
5335         $slurp.=$chunk;
5336     }
5337     my @lines = split /\012/, $slurp;
5338     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5339     undef $fh;
5340     # read header
5341     my($line_count,$last_updated);
5342     while (@lines) {
5343         my $shift = shift(@lines);
5344         last if $shift =~ /^\s*$/;
5345         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5346         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5347     }
5348     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5349     if (not defined $line_count) {
5350
5351         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5352 Please check the validity of the index file by comparing it to more
5353 than one CPAN mirror. I'll continue but problems seem likely to
5354 happen.\a
5355 });
5356
5357         $CPAN::Frontend->mysleep(5);
5358     } elsif ($line_count != scalar @lines) {
5359
5360         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5361 contains a Line-Count header of %d but I see %d lines there. Please
5362 check the validity of the index file by comparing it to more than one
5363 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5364 $index_target, $line_count, scalar(@lines));
5365
5366     }
5367     if (not defined $last_updated) {
5368
5369         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5370 Please check the validity of the index file by comparing it to more
5371 than one CPAN mirror. I'll continue but problems seem likely to
5372 happen.\a
5373 });
5374
5375         $CPAN::Frontend->mysleep(5);
5376     } else {
5377
5378         $CPAN::Frontend
5379             ->myprint(sprintf qq{  Database was generated on %s\n},
5380                       $last_updated);
5381         $DATE_OF_02 = $last_updated;
5382
5383         my $age = time;
5384         if ($CPAN::META->has_inst('HTTP::Date')) {
5385             require HTTP::Date;
5386             $age -= HTTP::Date::str2time($last_updated);
5387         } else {
5388             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5389             require Time::Local;
5390             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5391             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5392             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5393         }
5394         $age /= 3600*24;
5395         if ($age > 30) {
5396
5397             $CPAN::Frontend
5398                 ->mywarn(sprintf
5399                          qq{Warning: This index file is %d days old.
5400   Please check the host you chose as your CPAN mirror for staleness.
5401   I'll continue but problems seem likely to happen.\a\n},
5402                          $age);
5403
5404         } elsif ($age < -1) {
5405
5406             $CPAN::Frontend
5407                 ->mywarn(sprintf
5408                          qq{Warning: Your system date is %d days behind this index file!
5409   System time:          %s
5410   Timestamp index file: %s
5411   Please fix your system time, problems with the make command expected.\n},
5412                          -$age,
5413                          scalar gmtime,
5414                          $DATE_OF_02,
5415                         );
5416
5417         }
5418     }
5419
5420
5421     # A necessity since we have metadata_cache: delete what isn't
5422     # there anymore
5423     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5424     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5425     my(%exists);
5426     my $i = 0;
5427     my $painted = 0;
5428     foreach (@lines) {
5429         # before 1.56 we split into 3 and discarded the rest. From
5430         # 1.57 we assign remaining text to $comment thus allowing to
5431         # influence isa_perl
5432         my($mod,$version,$dist,$comment) = split " ", $_, 4;
5433         unless ($mod && defined $version && $dist) {
5434             $CPAN::Frontend->mywarn("Could not split line[$_]\n");
5435             next;
5436         }
5437         my($bundle,$id,$userid);
5438
5439         if ($mod eq 'CPAN' &&
5440             ! (
5441             CPAN::Queue->exists('Bundle::CPAN') ||
5442             CPAN::Queue->exists('CPAN')
5443             )
5444         ) {
5445             local($^W)= 0;
5446             if ($version > $CPAN::VERSION) {
5447                 $CPAN::Frontend->mywarn(qq{
5448   New CPAN.pm version (v$version) available.
5449   [Currently running version is v$CPAN::VERSION]
5450   You might want to try
5451     install CPAN
5452     reload cpan
5453   to both upgrade CPAN.pm and run the new version without leaving
5454   the current session.
5455
5456 }); #});
5457                 $CPAN::Frontend->mysleep(2);
5458                 $CPAN::Frontend->myprint(qq{\n});
5459             }
5460             last if $CPAN::Signal;
5461         } elsif ($mod =~ /^Bundle::(.*)/) {
5462             $bundle = $1;
5463         }
5464
5465         if ($bundle) {
5466             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5467             # Let's make it a module too, because bundles have so much
5468             # in common with modules.
5469
5470             # Changed in 1.57_63: seems like memory bloat now without
5471             # any value, so commented out
5472
5473             # $CPAN::META->instance('CPAN::Module',$mod);
5474
5475         } else {
5476
5477             # instantiate a module object
5478             $id = $CPAN::META->instance('CPAN::Module',$mod);
5479
5480         }
5481
5482         # Although CPAN prohibits same name with different version the
5483         # indexer may have changed the version for the same distro
5484         # since the last time ("Force Reindexing" feature)
5485         if ($id->cpan_file ne $dist
5486             ||
5487             $id->cpan_version ne $version
5488            ) {
5489             $userid = $id->userid || $self->userid($dist);
5490             $id->set(
5491                      'CPAN_USERID' => $userid,
5492                      'CPAN_VERSION' => $version,
5493                      'CPAN_FILE' => $dist,
5494                     );
5495         }
5496
5497         # instantiate a distribution object
5498         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5499         # we do not need CONTAINSMODS unless we do something with
5500         # this dist, so we better produce it on demand.
5501
5502         ## my $obj = $CPAN::META->instance(
5503         ##                                 'CPAN::Distribution' => $dist
5504         ##                                );
5505         ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5506         } else {
5507             $CPAN::META->instance(
5508                                   'CPAN::Distribution' => $dist
5509                                  )->set(
5510                                         'CPAN_USERID' => $userid,
5511                                         'CPAN_COMMENT' => $comment,
5512                                        );
5513         }
5514         if ($secondtime) {
5515             for my $name ($mod,$dist) {
5516                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5517                 $exists{$name} = undef;
5518             }
5519         }
5520         $i++;
5521         while (($painted/76) < ($i/@lines)) {
5522             $CPAN::Frontend->myprint(".");
5523             $painted++;
5524         }
5525         return if $CPAN::Signal;
5526     }
5527     $CPAN::Frontend->myprint("DONE\n");
5528     if ($secondtime) {
5529         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5530             for my $o ($CPAN::META->all_objects($class)) {
5531                 next if exists $exists{$o->{ID}};
5532                 $CPAN::META->delete($class,$o->{ID});
5533                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5534                 #     if $CPAN::DEBUG;
5535             }
5536         }
5537     }
5538 }
5539
5540 #-> sub CPAN::Index::rd_modlist ;
5541 sub rd_modlist {
5542     my($cl,$index_target) = @_;
5543     return unless defined $index_target;
5544     return if CPAN::_sqlite_running;
5545     $CPAN::Frontend->myprint("Going to read $index_target\n");
5546     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5547     local $_;
5548     my $slurp = "";
5549     my $chunk;
5550     while (my $bytes = $fh->READ(\$chunk,8192)) {
5551         $slurp.=$chunk;
5552     }
5553     my @eval2 = split /\012/, $slurp;
5554
5555     while (@eval2) {
5556         my $shift = shift(@eval2);
5557         if ($shift =~ /^Date:\s+(.*)/) {
5558             if ($DATE_OF_03 eq $1) {
5559                 $CPAN::Frontend->myprint("Unchanged.\n");
5560                 return;
5561             }
5562             ($DATE_OF_03) = $1;
5563         }
5564         last if $shift =~ /^\s*$/;
5565     }
5566     push @eval2, q{CPAN::Modulelist->data;};
5567     local($^W) = 0;
5568     my($compmt) = Safe->new("CPAN::Safe1");
5569     my($eval2) = join("\n", @eval2);
5570     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5571     my $ret = $compmt->reval($eval2);
5572     Carp::confess($@) if $@;
5573     return if $CPAN::Signal;
5574     my $i = 0;
5575     my $until = keys(%$ret);
5576     my $painted = 0;
5577     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5578     for (keys %$ret) {
5579         my $obj = $CPAN::META->instance("CPAN::Module",$_);
5580         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5581         $obj->set(%{$ret->{$_}});
5582         $i++;
5583         while (($painted/76) < ($i/$until)) {
5584             $CPAN::Frontend->myprint(".");
5585             $painted++;
5586         }
5587         return if $CPAN::Signal;
5588     }
5589     $CPAN::Frontend->myprint("DONE\n");
5590 }
5591
5592 #-> sub CPAN::Index::write_metadata_cache ;
5593 sub write_metadata_cache {
5594     my($self) = @_;
5595     return unless $CPAN::Config->{'cache_metadata'};
5596     return if CPAN::_sqlite_running;
5597     return unless $CPAN::META->has_usable("Storable");
5598     my $cache;
5599     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5600                       CPAN::Distribution)) {
5601         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5602     }
5603     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5604     $cache->{last_time} = $LAST_TIME;
5605     $cache->{DATE_OF_02} = $DATE_OF_02;
5606     $cache->{PROTOCOL} = PROTOCOL;
5607     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5608     eval { Storable::nstore($cache, $metadata_file) };
5609     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5610 }
5611
5612 #-> sub CPAN::Index::read_metadata_cache ;
5613 sub read_metadata_cache {
5614     my($self) = @_;
5615     return unless $CPAN::Config->{'cache_metadata'};
5616     return if CPAN::_sqlite_running;
5617     return unless $CPAN::META->has_usable("Storable");
5618     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5619     return unless -r $metadata_file and -f $metadata_file;
5620     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5621     my $cache;
5622     eval { $cache = Storable::retrieve($metadata_file) };
5623     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5624     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5625         $LAST_TIME = 0;
5626         return;
5627     }
5628     if (exists $cache->{PROTOCOL}) {
5629         if (PROTOCOL > $cache->{PROTOCOL}) {
5630             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5631                                             "with protocol v%s, requiring v%s\n",
5632                                             $cache->{PROTOCOL},
5633                                             PROTOCOL)
5634                                    );
5635             return;
5636         }
5637     } else {
5638         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5639                                 "with protocol v1.0\n");
5640         return;
5641     }
5642     my $clcnt = 0;
5643     my $idcnt = 0;
5644     while(my($class,$v) = each %$cache) {
5645         next unless $class =~ /^CPAN::/;
5646         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5647         while (my($id,$ro) = each %$v) {
5648             $CPAN::META->{readwrite}{$class}{$id} ||=
5649                 $class->new(ID=>$id, RO=>$ro);
5650             $idcnt++;
5651         }
5652         $clcnt++;
5653     }
5654     unless ($clcnt) { # sanity check
5655         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5656         return;
5657     }
5658     if ($idcnt < 1000) {
5659         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5660                                  "in $metadata_file\n");
5661         return;
5662     }
5663     $CPAN::META->{PROTOCOL} ||=
5664         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5665                             # does initialize to some protocol
5666     $LAST_TIME = $cache->{last_time};
5667     $DATE_OF_02 = $cache->{DATE_OF_02};
5668     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5669         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5670     return;
5671 }
5672
5673 package CPAN::InfoObj;
5674 use strict;
5675 use Cwd qw(chdir);
5676
5677 sub ro {
5678     my $self = shift;
5679     exists $self->{RO} and return $self->{RO};
5680 }
5681
5682 #-> sub CPAN::InfoObj::cpan_userid
5683 sub cpan_userid {
5684     my $self = shift;
5685     my $ro = $self->ro;
5686     if ($ro) {
5687         return $ro->{CPAN_USERID} || "N/A";
5688     } else {
5689         $self->debug("ID[$self->{ID}]");
5690         # N/A for bundles found locally
5691         return "N/A";
5692     }
5693 }
5694
5695 sub id { shift->{ID}; }
5696
5697 #-> sub CPAN::InfoObj::new ;
5698 sub new {
5699     my $this = bless {}, shift;
5700     %$this = @_;
5701     $this
5702 }
5703
5704 # The set method may only be used by code that reads index data or
5705 # otherwise "objective" data from the outside world. All session
5706 # related material may do anything else with instance variables but
5707 # must not touch the hash under the RO attribute. The reason is that
5708 # the RO hash gets written to Metadata file and is thus persistent.
5709
5710 #-> sub CPAN::InfoObj::safe_chdir ;
5711 sub safe_chdir {
5712   my($self,$todir) = @_;
5713   # we die if we cannot chdir and we are debuggable
5714   Carp::confess("safe_chdir called without todir argument")
5715         unless defined $todir and length $todir;
5716   if (chdir $todir) {
5717     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5718         if $CPAN::DEBUG;
5719   } else {
5720     if (-e $todir) {
5721         unless (-x $todir) {
5722             unless (chmod 0755, $todir) {
5723                 my $cwd = CPAN::anycwd();
5724                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5725                                         "permission to change the permission; cannot ".
5726                                         "chdir to '$todir'\n");
5727                 $CPAN::Frontend->mysleep(5);
5728                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5729                                        qq{to todir[$todir]: $!});
5730             }
5731         }
5732     } else {
5733         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5734     }
5735     if (chdir $todir) {
5736       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5737           if $CPAN::DEBUG;
5738     } else {
5739       my $cwd = CPAN::anycwd();
5740       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5741                              qq{to todir[$todir] (a chmod has been issued): $!});
5742     }
5743   }
5744 }
5745
5746 #-> sub CPAN::InfoObj::set ;
5747 sub set {
5748     my($self,%att) = @_;
5749     my $class = ref $self;
5750
5751     # This must be ||=, not ||, because only if we write an empty
5752     # reference, only then the set method will write into the readonly
5753     # area. But for Distributions that spring into existence, maybe
5754     # because of a typo, we do not like it that they are written into
5755     # the readonly area and made permanent (at least for a while) and
5756     # that is why we do not "allow" other places to call ->set.
5757     unless ($self->id) {
5758         CPAN->debug("Bug? Empty ID, rejecting");
5759         return;
5760     }
5761     my $ro = $self->{RO} =
5762         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5763
5764     while (my($k,$v) = each %att) {
5765         $ro->{$k} = $v;
5766     }
5767 }
5768
5769 #-> sub CPAN::InfoObj::as_glimpse ;
5770 sub as_glimpse {
5771     my($self) = @_;
5772     my(@m);
5773     my $class = ref($self);
5774     $class =~ s/^CPAN:://;
5775     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5776     push @m, sprintf "%-15s %s\n", $class, $id;
5777     join "", @m;
5778 }
5779
5780 #-> sub CPAN::InfoObj::as_string ;
5781 sub as_string {
5782     my($self) = @_;
5783     my(@m);
5784     my $class = ref($self);
5785     $class =~ s/^CPAN:://;
5786     push @m, $class, " id = $self->{ID}\n";
5787     my $ro;
5788     unless ($ro = $self->ro) {
5789         if (substr($self->{ID},-1,1) eq ".") { # directory
5790             $ro = +{};
5791         } else {
5792             $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5793             $CPAN::Frontend->mysleep(5);
5794             return;
5795         }
5796     }
5797     for (sort keys %$ro) {
5798         # next if m/^(ID|RO)$/;
5799         my $extra = "";
5800         if ($_ eq "CPAN_USERID") {
5801             $extra .= " (";
5802             $extra .= $self->fullname;
5803             my $email; # old perls!
5804             if ($email = $CPAN::META->instance("CPAN::Author",
5805                                                $self->cpan_userid
5806                                               )->email) {
5807                 $extra .= " <$email>";
5808             } else {
5809                 $extra .= " <no email>";
5810             }
5811             $extra .= ")";
5812         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5813             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5814             next;
5815         }
5816         next unless defined $ro->{$_};
5817         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5818     }
5819   KEY: for (sort keys %$self) {
5820         next if m/^(ID|RO)$/;
5821         unless (defined $self->{$_}) {
5822             delete $self->{$_};
5823             next KEY;
5824         }
5825         if (ref($self->{$_}) eq "ARRAY") {
5826             push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5827         } elsif (ref($self->{$_}) eq "HASH") {
5828             my $value;
5829             if (/^CONTAINSMODS$/) {
5830                 $value = join(" ",sort keys %{$self->{$_}});
5831             } elsif (/^prereq_pm$/) {
5832                 my @value;
5833                 my $v = $self->{$_};
5834                 for my $x (sort keys %$v) {
5835                     my @svalue;
5836                     for my $y (sort keys %{$v->{$x}}) {
5837                         push @svalue, "$y=>$v->{$x}{$y}";
5838                     }
5839                     push @value, "$x\:" . join ",", @svalue if @svalue;
5840                 }
5841                 $value = join ";", @value;
5842             } else {
5843                 $value = $self->{$_};
5844             }
5845             push @m, sprintf(
5846                              "    %-12s %s\n",
5847                              $_,
5848                              $value,
5849                             );
5850         } else {
5851             push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5852         }
5853     }
5854     join "", @m, "\n";
5855 }
5856
5857 #-> sub CPAN::InfoObj::fullname ;
5858 sub fullname {
5859     my($self) = @_;
5860     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5861 }
5862
5863 #-> sub CPAN::InfoObj::dump ;
5864 sub dump {
5865     my($self, $what) = @_;
5866     unless ($CPAN::META->has_inst("Data::Dumper")) {
5867         $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5868     }
5869     local $Data::Dumper::Sortkeys;
5870     $Data::Dumper::Sortkeys = 1;
5871     my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5872     if (length $out > 100000) {
5873         my $fh_pager = FileHandle->new;
5874         local($SIG{PIPE}) = "IGNORE";
5875         my $pager = $CPAN::Config->{'pager'} || "cat";
5876         $fh_pager->open("|$pager")
5877             or die "Could not open pager $pager\: $!";
5878         $fh_pager->print($out);
5879         close $fh_pager;
5880     } else {
5881         $CPAN::Frontend->myprint($out);
5882     }
5883 }
5884
5885 package CPAN::Author;
5886 use strict;
5887
5888 #-> sub CPAN::Author::force
5889 sub force {
5890     my $self = shift;
5891     $self->{force}++;
5892 }
5893
5894 #-> sub CPAN::Author::force
5895 sub unforce {
5896     my $self = shift;
5897     delete $self->{force};
5898 }
5899
5900 #-> sub CPAN::Author::id
5901 sub id {
5902     my $self = shift;
5903     my $id = $self->{ID};
5904     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5905     $id;
5906 }
5907
5908 #-> sub CPAN::Author::as_glimpse ;
5909 sub as_glimpse {
5910     my($self) = @_;
5911     my(@m);
5912     my $class = ref($self);
5913     $class =~ s/^CPAN:://;
5914     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5915                      $class,
5916                      $self->{ID},
5917                      $self->fullname,
5918                      $self->email);
5919     join "", @m;
5920 }
5921
5922 #-> sub CPAN::Author::fullname ;
5923 sub fullname {
5924     shift->ro->{FULLNAME};
5925 }
5926 *name = \&fullname;
5927
5928 #-> sub CPAN::Author::email ;
5929 sub email    { shift->ro->{EMAIL}; }
5930
5931 #-> sub CPAN::Author::ls ;
5932 sub ls {
5933     my $self = shift;
5934     my $glob = shift || "";
5935     my $silent = shift || 0;
5936     my $id = $self->id;
5937
5938     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5939     my(@csf); # chksumfile
5940     @csf = $self->id =~ /(.)(.)(.*)/;
5941     $csf[1] = join "", @csf[0,1];
5942     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5943     my(@dl);
5944     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5945     unless (grep {$_->[2] eq $csf[1]} @dl) {
5946         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5947         return;
5948     }
5949     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5950     unless (grep {$_->[2] eq $csf[2]} @dl) {
5951         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5952         return;
5953     }
5954     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5955     if ($glob) {
5956         if ($CPAN::META->has_inst("Text::Glob")) {
5957             my $rglob = Text::Glob::glob_to_regex($glob);
5958             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5959         } else {
5960             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5961         }
5962     }
5963     unless ($silent >= 2) {
5964         $CPAN::Frontend->myprint(join "", map {
5965             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5966         } sort { $a->[2] cmp $b->[2] } @dl);
5967     }
5968     @dl;
5969 }
5970
5971 # returns an array of arrays, the latter contain (size,mtime,filename)
5972 #-> sub CPAN::Author::dir_listing ;
5973 sub dir_listing {
5974     my $self = shift;
5975     my $chksumfile = shift;
5976     my $recursive = shift;
5977     my $may_ftp = shift;
5978
5979     my $lc_want =
5980         File::Spec->catfile($CPAN::Config->{keep_source_where},
5981                             "authors", "id", @$chksumfile);
5982
5983     my $fh;
5984
5985     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5986     # hazard.  (Without GPG installed they are not that much better,
5987     # though.)
5988     $fh = FileHandle->new;
5989     if (open($fh, $lc_want)) {
5990         my $line = <$fh>; close $fh;
5991         unlink($lc_want) unless $line =~ /PGP/;
5992     }
5993
5994     local($") = "/";
5995     # connect "force" argument with "index_expire".
5996     my $force = $self->{force};
5997     if (my @stat = stat $lc_want) {
5998         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5999     }
6000     my $lc_file;
6001     if ($may_ftp) {
6002         $lc_file = CPAN::FTP->localize(
6003                                        "authors/id/@$chksumfile",
6004                                        $lc_want,
6005                                        $force,
6006                                       );
6007         unless ($lc_file) {
6008             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6009             $chksumfile->[-1] .= ".gz";
6010             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
6011                                            "$lc_want.gz",1);
6012             if ($lc_file) {
6013                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
6014                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6015             } else {
6016                 return;
6017             }
6018         }
6019     } else {
6020         $lc_file = $lc_want;
6021         # we *could* second-guess and if the user has a file: URL,
6022         # then we could look there. But on the other hand, if they do
6023         # have a file: URL, wy did they choose to set
6024         # $CPAN::Config->{show_upload_date} to false?
6025     }
6026
6027     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
6028     $fh = FileHandle->new;
6029     my($cksum);
6030     if (open $fh, $lc_file) {
6031         local($/);
6032         my $eval = <$fh>;
6033         $eval =~ s/\015?\012/\n/g;
6034         close $fh;
6035         my($compmt) = Safe->new();
6036         $cksum = $compmt->reval($eval);
6037         if ($@) {
6038             rename $lc_file, "$lc_file.bad";
6039             Carp::confess($@) if $@;
6040         }
6041     } elsif ($may_ftp) {
6042         Carp::carp "Could not open '$lc_file' for reading.";
6043     } else {
6044         # Maybe should warn: "You may want to set show_upload_date to a true value"
6045         return;
6046     }
6047     my(@result,$f);
6048     for $f (sort keys %$cksum) {
6049         if (exists $cksum->{$f}{isdir}) {
6050             if ($recursive) {
6051                 my(@dir) = @$chksumfile;
6052                 pop @dir;
6053                 push @dir, $f, "CHECKSUMS";
6054                 push @result, map {
6055                     [$_->[0], $_->[1], "$f/$_->[2]"]
6056                 } $self->dir_listing(\@dir,1,$may_ftp);
6057             } else {
6058                 push @result, [ 0, "-", $f ];
6059             }
6060         } else {
6061             push @result, [
6062                            ($cksum->{$f}{"size"}||0),
6063                            $cksum->{$f}{"mtime"}||"---",
6064                            $f
6065                           ];
6066         }
6067     }
6068     @result;
6069 }
6070
6071 #-> sub CPAN::Author::reports
6072 sub reports {
6073     $CPAN::Frontend->mywarn("reports on authors not implemented.
6074 Please file a bugreport if you need this.\n");
6075 }
6076
6077 package CPAN::Distribution;
6078 use strict;
6079 use Cwd qw(chdir);
6080 use CPAN::Distroprefs;
6081
6082 # Accessors
6083 sub cpan_comment {
6084     my $self = shift;
6085     my $ro = $self->ro or return;
6086     $ro->{CPAN_COMMENT}
6087 }
6088
6089 #-> CPAN::Distribution::undelay
6090 sub undelay {
6091     my $self = shift;
6092     for my $delayer (
6093                      "configure_requires_later",
6094                      "configure_requires_later_for",
6095                      "later",
6096                      "later_for",
6097                     ) {
6098         delete $self->{$delayer};
6099     }
6100 }
6101
6102 #-> CPAN::Distribution::is_dot_dist
6103 sub is_dot_dist {
6104     my($self) = @_;
6105     return substr($self->id,-1,1) eq ".";
6106 }
6107
6108 # add the A/AN/ stuff
6109 #-> CPAN::Distribution::normalize
6110 sub normalize {
6111     my($self,$s) = @_;
6112     $s = $self->id unless defined $s;
6113     if (substr($s,-1,1) eq ".") {
6114         # using a global because we are sometimes called as static method
6115         if (!$CPAN::META->{LOCK}
6116             && !$CPAN::Have_warned->{"$s is unlocked"}++
6117            ) {
6118             $CPAN::Frontend->mywarn("You are visiting the local directory
6119   '$s'
6120   without lock, take care that concurrent processes do not do likewise.\n");
6121             $CPAN::Frontend->mysleep(1);
6122         }
6123         if ($s eq ".") {
6124             $s = "$CPAN::iCwd/.";
6125         } elsif (File::Spec->file_name_is_absolute($s)) {
6126         } elsif (File::Spec->can("rel2abs")) {
6127             $s = File::Spec->rel2abs($s);
6128         } else {
6129             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
6130         }
6131         CPAN->debug("s[$s]") if $CPAN::DEBUG;
6132         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
6133             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
6134                 $_->{build_dir} = $s;
6135                 $_->{archived} = "local_directory";
6136                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
6137             }
6138         }
6139     } elsif (
6140         $s =~ tr|/|| == 1
6141         or
6142         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
6143        ) {
6144         return $s if $s =~ m:^N/A|^Contact Author: ;
6145         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
6146         CPAN->debug("s[$s]") if $CPAN::DEBUG;
6147     }
6148     $s;
6149 }
6150
6151 #-> sub CPAN::Distribution::author ;
6152 sub author {
6153     my($self) = @_;
6154     my($authorid);
6155     if (substr($self->id,-1,1) eq ".") {
6156         $authorid = "LOCAL";
6157     } else {
6158         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
6159     }
6160     CPAN::Shell->expand("Author",$authorid);
6161 }
6162
6163 # tries to get the yaml from CPAN instead of the distro itself:
6164 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
6165 sub fast_yaml {
6166     my($self) = @_;
6167     my $meta = $self->pretty_id;
6168     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
6169     my(@ls) = CPAN::Shell->globls($meta);
6170     my $norm = $self->normalize($meta);
6171
6172     my($local_file);
6173     my($local_wanted) =
6174         File::Spec->catfile(
6175                             $CPAN::Config->{keep_source_where},
6176                             "authors",
6177                             "id",
6178                             split(/\//,$norm)
6179                            );
6180     $self->debug("Doing localize") if $CPAN::DEBUG;
6181     unless ($local_file =
6182             CPAN::FTP->localize("authors/id/$norm",
6183                                 $local_wanted)) {
6184         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
6185     }
6186     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
6187 }
6188
6189 #-> sub CPAN::Distribution::cpan_userid
6190 sub cpan_userid {
6191     my $self = shift;
6192     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
6193         return $1;
6194     }
6195     return $self->SUPER::cpan_userid;
6196 }
6197
6198 #-> sub CPAN::Distribution::pretty_id
6199 sub pretty_id {
6200     my $self = shift;
6201     my $id = $self->id;
6202     return $id unless $id =~ m|^./../|;
6203     substr($id,5);
6204 }
6205
6206 #-> sub CPAN::Distribution::base_id
6207 sub base_id {
6208     my $self = shift;
6209     my $id = $self->pretty_id();
6210     my $base_id = File::Basename::basename($id);
6211     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
6212     return $base_id;
6213 }
6214
6215 #-> sub CPAN::Distribution::tested_ok_but_not_installed
6216 sub tested_ok_but_not_installed {
6217     my $self = shift;
6218     return (
6219            $self->{make_test}
6220         && $self->{build_dir}
6221         && (UNIVERSAL::can($self->{make_test},"failed") ?
6222              ! $self->{make_test}->failed :
6223              $self->{make_test} =~ /^YES/
6224             )
6225         && (
6226             !$self->{install}
6227             ||
6228             $self->{install}->failed
6229            )
6230     );
6231 }
6232
6233
6234 # mark as dirty/clean for the sake of recursion detection. $color=1
6235 # means "in use", $color=0 means "not in use anymore". $color=2 means
6236 # we have determined prereqs now and thus insist on passing this
6237 # through (at least) once again.
6238
6239 #-> sub CPAN::Distribution::color_cmd_tmps ;
6240 sub color_cmd_tmps {
6241     my($self) = shift;
6242     my($depth) = shift || 0;
6243     my($color) = shift || 0;
6244     my($ancestors) = shift || [];
6245     # a distribution needs to recurse into its prereq_pms
6246
6247     return if exists $self->{incommandcolor}
6248         && $color==1
6249         && $self->{incommandcolor}==$color;
6250     if ($depth>=$CPAN::MAX_RECURSION) {
6251         die(CPAN::Exception::RecursiveDependency->new($ancestors));
6252     }
6253     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6254     my $prereq_pm = $self->prereq_pm;
6255     if (defined $prereq_pm) {
6256       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
6257                            keys %{$prereq_pm->{build_requires}||{}}) {
6258             next PREREQ if $pre eq "perl";
6259             my $premo;
6260             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
6261                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
6262                 $CPAN::Frontend->mysleep(2);
6263                 next PREREQ;
6264             }
6265             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6266         }
6267     }
6268     if ($color==0) {
6269         delete $self->{sponsored_mods};
6270
6271         # as we are at the end of a command, we'll give up this
6272         # reminder of a broken test. Other commands may test this guy
6273         # again. Maybe 'badtestcnt' should be renamed to
6274         # 'make_test_failed_within_command'?
6275         delete $self->{badtestcnt};
6276     }
6277     $self->{incommandcolor} = $color;
6278 }
6279
6280 #-> sub CPAN::Distribution::as_string ;
6281 sub as_string {
6282     my $self = shift;
6283     $self->containsmods;
6284     $self->upload_date;
6285     $self->SUPER::as_string(@_);
6286 }
6287
6288 #-> sub CPAN::Distribution::containsmods ;
6289 sub containsmods {
6290     my $self = shift;
6291     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6292     my $dist_id = $self->{ID};
6293     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6294         my $mod_file = $mod->cpan_file or next;
6295         my $mod_id = $mod->{ID} or next;
6296         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6297         # sleep 1;
6298         if ($CPAN::Signal) {
6299             delete $self->{CONTAINSMODS};
6300             return;
6301         }
6302         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6303     }
6304     keys %{$self->{CONTAINSMODS}||={}};
6305 }
6306
6307 #-> sub CPAN::Distribution::upload_date ;
6308 sub upload_date {
6309     my $self = shift;
6310     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6311     my(@local_wanted) = split(/\//,$self->id);
6312     my $filename = pop @local_wanted;
6313     push @local_wanted, "CHECKSUMS";
6314     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6315     return unless $author;
6316     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6317     return unless @dl;
6318     my($dirent) = grep { $_->[2] eq $filename } @dl;
6319     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6320     return unless $dirent->[1];
6321     return $self->{UPLOAD_DATE} = $dirent->[1];
6322 }
6323
6324 #-> sub CPAN::Distribution::uptodate ;
6325 sub uptodate {
6326     my($self) = @_;
6327     my $c;
6328     foreach $c ($self->containsmods) {
6329         my $obj = CPAN::Shell->expandany($c);
6330         unless ($obj->uptodate) {
6331             my $id = $self->pretty_id;
6332             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6333             return 0;
6334         }
6335     }
6336     return 1;
6337 }
6338
6339 #-> sub CPAN::Distribution::called_for ;
6340 sub called_for {
6341     my($self,$id) = @_;
6342     $self->{CALLED_FOR} = $id if defined $id;
6343     return $self->{CALLED_FOR};
6344 }
6345
6346 #-> sub CPAN::Distribution::get ;
6347 sub get {
6348     my($self) = @_;
6349     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6350     if (my $goto = $self->prefs->{goto}) {
6351         $CPAN::Frontend->mywarn
6352             (sprintf(
6353                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6354                      $goto,
6355                      $self->{prefs_file},
6356                      $self->{prefs_file_doc},
6357                     ));
6358         return $self->goto($goto);
6359     }
6360     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6361                            ? $ENV{PERL5LIB}
6362                            : ($ENV{PERLLIB} || "");
6363     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
6364     $CPAN::META->set_perl5lib;
6365     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6366
6367   EXCUSE: {
6368         my @e;
6369         my $goodbye_message;
6370         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6371         if ($self->prefs->{disabled} && ! $self->{force_update}) {
6372             my $why = sprintf(
6373                               "Disabled via prefs file '%s' doc %d",
6374                               $self->{prefs_file},
6375                               $self->{prefs_file_doc},
6376                              );
6377             push @e, $why;
6378             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6379             $goodbye_message = "[disabled] -- NA $why";
6380             # note: not intended to be persistent but at least visible
6381             # during this session
6382         } else {
6383             if (exists $self->{build_dir} && -d $self->{build_dir}
6384                 && ($self->{modulebuild}||$self->{writemakefile})
6385                ) {
6386                 # this deserves print, not warn:
6387                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6388                                          "$self->{build_dir}\n"
6389                                         );
6390                 return 1;
6391             }
6392
6393             # although we talk about 'force' we shall not test on
6394             # force directly. New model of force tries to refrain from
6395             # direct checking of force.
6396             exists $self->{unwrapped} and (
6397                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
6398                                            $self->{unwrapped}->failed :
6399                                            $self->{unwrapped} =~ /^NO/
6400                                           )
6401                 and push @e, "Unwrapping had some problem, won't try again without force";
6402         }
6403         if (@e) {
6404             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6405             if ($goodbye_message) {
6406                  $self->goodbye($goodbye_message);
6407             }
6408             return;
6409         }
6410     }
6411     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6412
6413     my($local_file);
6414     unless ($self->{build_dir} && -d $self->{build_dir}) {
6415         $self->get_file_onto_local_disk;
6416         return if $CPAN::Signal;
6417         $self->check_integrity;
6418         return if $CPAN::Signal;
6419         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6420         if (exists $self->{writemakefile} && ref $self->{writemakefile}
6421            && $self->{writemakefile}->can("failed") &&
6422            $self->{writemakefile}->failed) {
6423             return;
6424         }
6425         $packagedir ||= $self->{build_dir};
6426         $self->{build_dir} = $packagedir;
6427     }
6428
6429     if ($CPAN::Signal) {
6430         $self->safe_chdir($sub_wd);
6431         return;
6432     }
6433     return $self->choose_MM_or_MB($local_file);
6434 }
6435
6436 #-> CPAN::Distribution::get_file_onto_local_disk
6437 sub get_file_onto_local_disk {
6438     my($self) = @_;
6439
6440     return if $self->is_dot_dist;
6441     my($local_file);
6442     my($local_wanted) =
6443         File::Spec->catfile(
6444                             $CPAN::Config->{keep_source_where},
6445                             "authors",
6446                             "id",
6447                             split(/\//,$self->id)
6448                            );
6449
6450     $self->debug("Doing localize") if $CPAN::DEBUG;
6451     unless ($local_file =
6452             CPAN::FTP->localize("authors/id/$self->{ID}",
6453                                 $local_wanted)) {
6454         my $note = "";
6455         if ($CPAN::Index::DATE_OF_02) {
6456             $note = "Note: Current database in memory was generated ".
6457                 "on $CPAN::Index::DATE_OF_02\n";
6458         }
6459         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6460     }
6461
6462     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6463     $self->{localfile} = $local_file;
6464 }
6465
6466
6467 #-> CPAN::Distribution::check_integrity
6468 sub check_integrity {
6469     my($self) = @_;
6470
6471     return if $self->is_dot_dist;
6472     if ($CPAN::META->has_inst("Digest::SHA")) {
6473         $self->debug("Digest::SHA is installed, verifying");
6474         $self->verifyCHECKSUM;
6475     } else {
6476         $self->debug("Digest::SHA is NOT installed");
6477     }
6478 }
6479
6480 #-> CPAN::Distribution::run_preps_on_packagedir
6481 sub run_preps_on_packagedir {
6482     my($self) = @_;
6483     return if $self->is_dot_dist;
6484
6485     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6486     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6487     $self->safe_chdir($builddir);
6488     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6489     File::Path::rmtree("tmp-$$");
6490     unless (mkdir "tmp-$$", 0755) {
6491         $CPAN::Frontend->unrecoverable_error(<<EOF);
6492 Couldn't mkdir '$builddir/tmp-$$': $!
6493
6494 Cannot continue: Please find the reason why I cannot make the
6495 directory
6496 $builddir/tmp-$$
6497 and fix the problem, then retry.
6498
6499 EOF
6500     }
6501     if ($CPAN::Signal) {
6502         return;
6503     }
6504     $self->safe_chdir("tmp-$$");
6505
6506     #
6507     # Unpack the goods
6508     #
6509     my $local_file = $self->{localfile};
6510     my $ct = eval{CPAN::Tarzip->new($local_file)};
6511     unless ($ct) {
6512         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6513         delete $self->{build_dir};
6514         return;
6515     }
6516     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6517         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6518         $self->untar_me($ct);
6519     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6520         $self->unzip_me($ct);
6521     } else {
6522         $self->{was_uncompressed}++ unless $ct->gtest();
6523         $local_file = $self->handle_singlefile($local_file);
6524     }
6525
6526     # we are still in the tmp directory!
6527     # Let's check if the package has its own directory.
6528     my $dh = DirHandle->new(File::Spec->curdir)
6529         or Carp::croak("Couldn't opendir .: $!");
6530     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6531     if (grep { $_ eq "pax_global_header" } @readdir) {
6532         $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
6533 from the tarball '$local_file'.
6534 This is almost certainly an error. Please upgrade your tar.
6535 I'll ignore this file for now.
6536 See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
6537         $CPAN::Frontend->mysleep(5);
6538         @readdir = grep { $_ ne "pax_global_header" } @readdir;
6539     }
6540     $dh->close;
6541     my ($packagedir);
6542     # XXX here we want in each branch File::Temp to protect all build_dir directories
6543     if (CPAN->has_usable("File::Temp")) {
6544         my $tdir_base;
6545         my $from_dir;
6546         my @dirents;
6547         if (@readdir == 1 && -d $readdir[0]) {
6548             $tdir_base = $readdir[0];
6549             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6550             my $dh2;
6551             unless ($dh2 = DirHandle->new($from_dir)) {
6552                 my($mode) = (stat $from_dir)[2];
6553                 my $why = sprintf
6554                     (
6555                      "Couldn't opendir '%s', mode '%o': %s",
6556                      $from_dir,
6557                      $mode,
6558                      $!,
6559                     );
6560                 $CPAN::Frontend->mywarn("$why\n");
6561                 $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
6562                 return;
6563             }
6564             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6565         } else {
6566             my $userid = $self->cpan_userid;
6567             CPAN->debug("userid[$userid]");
6568             if (!$userid or $userid eq "N/A") {
6569                 $userid = "anon";
6570             }
6571             $tdir_base = $userid;
6572             $from_dir = File::Spec->curdir;
6573             @dirents = @readdir;
6574         }
6575         $packagedir = File::Temp::tempdir(
6576                                           "$tdir_base-XXXXXX",
6577                                           DIR => $builddir,
6578                                           CLEANUP => 0,
6579                                          );
6580         my $f;
6581         for $f (@dirents) { # is already without "." and ".."
6582             my $from = File::Spec->catdir($from_dir,$f);
6583             my $to = File::Spec->catdir($packagedir,$f);
6584             unless (File::Copy::move($from,$to)) {
6585                 my $err = $!;
6586                 $from = File::Spec->rel2abs($from);
6587                 Carp::confess("Couldn't move $from to $to: $err");
6588             }
6589         }
6590     } else { # older code below, still better than nothing when there is no File::Temp
6591         my($distdir);
6592         if (@readdir == 1 && -d $readdir[0]) {
6593             $distdir = $readdir[0];
6594             $packagedir = File::Spec->catdir($builddir,$distdir);
6595             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6596                 if $CPAN::DEBUG;
6597             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6598                                                         "$packagedir\n");
6599             File::Path::rmtree($packagedir);
6600             unless (File::Copy::move($distdir,$packagedir)) {
6601                 $CPAN::Frontend->unrecoverable_error(<<EOF);
6602 Couldn't move '$distdir' to '$packagedir': $!
6603
6604 Cannot continue: Please find the reason why I cannot move
6605 $builddir/tmp-$$/$distdir
6606 to
6607 $packagedir
6608 and fix the problem, then retry
6609
6610 EOF
6611             }
6612             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6613                                  $distdir,
6614                                  $packagedir,
6615                                  -e $packagedir,
6616                                  -d $packagedir,
6617                                 )) if $CPAN::DEBUG;
6618         } else {
6619             my $userid = $self->cpan_userid;
6620             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6621             if (!$userid or $userid eq "N/A") {
6622                 $userid = "anon";
6623             }
6624             my $pragmatic_dir = $userid . '000';
6625             $pragmatic_dir =~ s/\W_//g;
6626             $pragmatic_dir++ while -d "../$pragmatic_dir";
6627             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6628             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6629             File::Path::mkpath($packagedir);
6630             my($f);
6631             for $f (@readdir) { # is already without "." and ".."
6632                 my $to = File::Spec->catdir($packagedir,$f);
6633                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6634             }
6635         }
6636     }
6637     $self->{build_dir} = $packagedir;
6638     $self->safe_chdir($builddir);
6639     File::Path::rmtree("tmp-$$");
6640
6641     $self->safe_chdir($packagedir);
6642     $self->_signature_business();
6643     $self->safe_chdir($builddir);
6644
6645     return($packagedir,$local_file);
6646 }
6647
6648 #-> sub CPAN::Distribution::parse_meta_yml ;
6649 sub parse_meta_yml {
6650     my($self) = @_;
6651     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6652     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6653     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6654     return unless -f $yaml;
6655     my $early_yaml;
6656     eval {
6657         require Parse::CPAN::Meta;
6658         $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0];
6659     };
6660     unless ($early_yaml) {
6661         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6662     }
6663     unless ($early_yaml) {
6664         return;
6665     }
6666     return $early_yaml;
6667 }
6668
6669 #-> sub CPAN::Distribution::satisfy_requires ;
6670 sub satisfy_requires {
6671     my ($self) = @_;
6672     if (my @prereq = $self->unsat_prereq("later")) {
6673         if ($prereq[0][0] eq "perl") {
6674             my $need = "requires perl '$prereq[0][1]'";
6675             my $id = $self->pretty_id;
6676             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6677             $self->{make} = CPAN::Distrostatus->new("NO $need");
6678             $self->store_persistent_state;
6679             die "[prereq] -- NOT OK\n";
6680         } else {
6681             my $follow = eval { $self->follow_prereqs("later",@prereq); };
6682             if (0) {
6683             } elsif ($follow) {
6684                 # signal success to the queuerunner
6685                 return 1;
6686             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6687                 $CPAN::Frontend->mywarn($@);
6688                 die "[depend] -- NOT OK\n";
6689             }
6690         }
6691     }
6692 }
6693
6694 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6695 sub satisfy_configure_requires {
6696     my($self) = @_;
6697     my $enable_configure_requires = 1;
6698     if (!$enable_configure_requires) {
6699         return 1;
6700         # if we return 1 here, everything is as before we introduced
6701         # configure_requires that means, things with
6702         # configure_requires simply fail, all others succeed
6703     }
6704     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6705     if ($self->{configure_requires_later}) {
6706         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6707             if ($self->{configure_requires_later_for}{$k}>1) {
6708                 # we must not come here a second time
6709                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6710                 require YAML::Syck;
6711                 $CPAN::Frontend->mydie
6712                     (
6713                      YAML::Syck::Dump
6714                      ({self=>$self, prereq=>\@prereq})
6715                     );
6716             }
6717         }
6718     }
6719     if ($prereq[0][0] eq "perl") {
6720         my $need = "requires perl '$prereq[0][1]'";
6721         my $id = $self->pretty_id;
6722         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6723         $self->{make} = CPAN::Distrostatus->new("NO $need");
6724         $self->store_persistent_state;
6725         return $self->goodbye("[prereq] -- NOT OK");
6726     } else {
6727         my $follow = eval {
6728             $self->follow_prereqs("configure_requires_later", @prereq);
6729         };
6730         if (0) {
6731         } elsif ($follow) {
6732             return;
6733         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6734             $CPAN::Frontend->mywarn($@);
6735             return $self->goodbye("[depend] -- NOT OK");
6736         }
6737     }
6738     die "never reached";
6739 }
6740
6741 #-> sub CPAN::Distribution::choose_MM_or_MB ;
6742 sub choose_MM_or_MB {
6743     my($self,$local_file) = @_;
6744     $self->satisfy_configure_requires() or return;
6745     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6746     my($mpl_exists) = -f $mpl;
6747     unless ($mpl_exists) {
6748         # NFS has been reported to have racing problems after the
6749         # renaming of a directory in some environments.
6750         # This trick helps.
6751         $CPAN::Frontend->mysleep(1);
6752         my $mpldh = DirHandle->new($self->{build_dir})
6753             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6754         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6755         $mpldh->close;
6756     }
6757     my $prefer_installer = "eumm"; # eumm|mb
6758     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6759         if ($mpl_exists) { # they *can* choose
6760             if ($CPAN::META->has_inst("Module::Build")) {
6761                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6762                                                                      q{prefer_installer});
6763             }
6764         } else {
6765             $prefer_installer = "mb";
6766         }
6767     }
6768     return unless $self->patch;
6769     if (lc($prefer_installer) eq "rand") {
6770         $prefer_installer = rand()<.5 ? "eumm" : "mb";
6771     }
6772     if (lc($prefer_installer) eq "mb") {
6773         $self->{modulebuild} = 1;
6774     } elsif ($self->{archived} eq "patch") {
6775         # not an edge case, nothing to install for sure
6776         my $why = "A patch file cannot be installed";
6777         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6778         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6779     } elsif (! $mpl_exists) {
6780         $self->_edge_cases($mpl,$local_file);
6781     }
6782     if ($self->{build_dir}
6783         &&
6784         $CPAN::Config->{build_dir_reuse}
6785        ) {
6786         $self->store_persistent_state;
6787     }
6788     return $self;
6789 }
6790
6791 #-> CPAN::Distribution::store_persistent_state
6792 sub store_persistent_state {
6793     my($self) = @_;
6794     my $dir = $self->{build_dir};
6795     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6796             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6797         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6798                                 "will not store persistent state\n");
6799         return;
6800     }
6801     my $file = sprintf "%s.yml", $dir;
6802     my $yaml_module = CPAN::_yaml_module;
6803     if ($CPAN::META->has_inst($yaml_module)) {
6804         CPAN->_yaml_dumpfile(
6805                              $file,
6806                              {
6807                               time => time,
6808                               perl => CPAN::_perl_fingerprint,
6809                               distribution => $self,
6810                              }
6811                             );
6812     } else {
6813         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6814                                 "will not store persistent state\n");
6815     }
6816 }
6817
6818 #-> CPAN::Distribution::try_download
6819 sub try_download {
6820     my($self,$patch) = @_;
6821     my $norm = $self->normalize($patch);
6822     my($local_wanted) =
6823         File::Spec->catfile(
6824                             $CPAN::Config->{keep_source_where},
6825                             "authors",
6826                             "id",
6827                             split(/\//,$norm),
6828                            );
6829     $self->debug("Doing localize") if $CPAN::DEBUG;
6830     return CPAN::FTP->localize("authors/id/$norm",
6831                                $local_wanted);
6832 }
6833
6834 {
6835     my $stdpatchargs = "";
6836     #-> CPAN::Distribution::patch
6837     sub patch {
6838         my($self) = @_;
6839         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6840         my $patches = $self->prefs->{patches};
6841         $patches ||= "";
6842         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6843         if ($patches) {
6844             return unless @$patches;
6845             $self->safe_chdir($self->{build_dir});
6846             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6847             my $patchbin = $CPAN::Config->{patch};
6848             unless ($patchbin && length $patchbin) {
6849                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6850                                        "Please run 'o conf init /patch/'\n\n");
6851             }
6852             unless (MM->maybe_command($patchbin)) {
6853                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6854                                        "Please run 'o conf init /patch/'\n\n");
6855             }
6856             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6857             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6858             unless ($stdpatchargs) {
6859                 my $system = "$patchbin --version |";
6860                 local *FH;
6861                 open FH, $system or die "Could not fork '$system': $!";
6862                 local $/ = "\n";
6863                 my $pversion;
6864               PARSEVERSION: while (<FH>) {
6865                     if (/^patch\s+([\d\.]+)/) {
6866                         $pversion = $1;
6867                         last PARSEVERSION;
6868                     }
6869                 }
6870                 if ($pversion) {
6871                     $stdpatchargs = "-N --fuzz=3";
6872                 } else {
6873                     $stdpatchargs = "-N";
6874                 }
6875             }
6876             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6877             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6878             for my $patch (@$patches) {
6879                 unless (-f $patch) {
6880                     if (my $trydl = $self->try_download($patch)) {
6881                         $patch = $trydl;
6882                     } else {
6883                         my $fail = "Could not find patch '$patch'";
6884                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6885                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6886                         delete $self->{build_dir};
6887                         return;
6888                     }
6889                 }
6890                 $CPAN::Frontend->myprint("  $patch\n");
6891                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6892
6893                 my $pcommand;
6894                 my $ppp = $self->_patch_p_parameter($readfh);
6895                 if ($ppp eq "applypatch") {
6896                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6897                 } else {
6898                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6899                     $pcommand = "$patchbin $thispatchargs";
6900                 }
6901
6902                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6903                 my $writefh = FileHandle->new;
6904                 $CPAN::Frontend->myprint("  $pcommand\n");
6905                 unless (open $writefh, "|$pcommand") {
6906                     my $fail = "Could not fork '$pcommand'";
6907                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6908                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6909                     delete $self->{build_dir};
6910                     return;
6911                 }
6912                 while (my $x = $readfh->READLINE) {
6913                     print $writefh $x;
6914                 }
6915                 unless (close $writefh) {
6916                     my $fail = "Could not apply patch '$patch'";
6917                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6918                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6919                     delete $self->{build_dir};
6920                     return;
6921                 }
6922             }
6923             $self->{patched}++;
6924         }
6925         return 1;
6926     }
6927 }
6928
6929 sub _patch_p_parameter {
6930     my($self,$fh) = @_;
6931     my $cnt_files   = 0;
6932     my $cnt_p0files = 0;
6933     local($_);
6934     while ($_ = $fh->READLINE) {
6935         if (
6936             $CPAN::Config->{applypatch}
6937             &&
6938             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6939            ) {
6940             return "applypatch"
6941         }
6942         next unless /^[\*\+]{3}\s(\S+)/;
6943         my $file = $1;
6944         $cnt_files++;
6945         $cnt_p0files++ if -f $file;
6946         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6947             if $CPAN::DEBUG;
6948     }
6949     return "-p1" unless $cnt_files;
6950     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6951 }
6952
6953 #-> sub CPAN::Distribution::_edge_cases
6954 # with "configure" or "Makefile" or single file scripts
6955 sub _edge_cases {
6956     my($self,$mpl,$local_file) = @_;
6957     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6958                          $mpl,
6959                          CPAN::anycwd(),
6960                         )) if $CPAN::DEBUG;
6961     my $build_dir = $self->{build_dir};
6962     my($configure) = File::Spec->catfile($build_dir,"Configure");
6963     if (-f $configure) {
6964         # do we have anything to do?
6965         $self->{configure} = $configure;
6966     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6967         $CPAN::Frontend->mywarn(qq{
6968 Package comes with a Makefile and without a Makefile.PL.
6969 We\'ll try to build it with that Makefile then.
6970 });
6971         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6972         $CPAN::Frontend->mysleep(2);
6973     } else {
6974         my $cf = $self->called_for || "unknown";
6975         if ($cf =~ m|/|) {
6976             $cf =~ s|.*/||;
6977             $cf =~ s|\W.*||;
6978         }
6979         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6980         $cf = "unknown" unless length($cf);
6981         if (my $crap = $self->_contains_crap($build_dir)) {
6982             my $why = qq{Package contains $crap; not recognized as a perl package, giving up};
6983             $CPAN::Frontend->mywarn("$why\n");
6984             $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
6985             return;
6986         }
6987         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6988   (The test -f "$mpl" returned false.)
6989   Writing one on our own (setting NAME to $cf)\a\n});
6990         $self->{had_no_makefile_pl}++;
6991         $CPAN::Frontend->mysleep(3);
6992
6993         # Writing our own Makefile.PL
6994
6995         my $exefile_stanza = "";
6996         if ($self->{archived} eq "maybe_pl") {
6997             $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
6998         }
6999
7000         my $fh = FileHandle->new;
7001         $fh->open(">$mpl")
7002             or Carp::croak("Could not open >$mpl: $!");
7003         $fh->print(
7004                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
7005 # because there was no Makefile.PL supplied.
7006 # Autogenerated on: }.scalar localtime().qq{
7007
7008 use ExtUtils::MakeMaker;
7009 WriteMakefile(
7010               NAME => q[$cf],$exefile_stanza
7011              );
7012 });
7013         $fh->close;
7014     }
7015 }
7016
7017 #-> CPAN;:Distribution::_contains_crap
7018 sub _contains_crap {
7019     my($self,$dir) = @_;
7020     my(@dirs, $dh, @files);
7021     opendir $dh, $dir or return;
7022     my $dirent;
7023     for $dirent (readdir $dh) {
7024         next if $dirent =~ /^\.\.?$/;
7025         my $path = File::Spec->catdir($dir,$dirent);
7026         if (-d $path) {
7027             push @dirs, $dirent;
7028         } elsif (-f $path) {
7029             push @files, $dirent;
7030         }
7031     }
7032     if (@dirs && @files) {
7033         return "both files[@files] and directories[@dirs]";
7034     } elsif (@files > 2) {
7035         return "several files[@files] but no Makefile.PL or Build.PL";
7036     }
7037     return;
7038 }
7039
7040 #-> CPAN;:Distribution::_exefile_stanza
7041 sub _exefile_stanza {
7042     my($self,$build_dir,$local_file) = @_;
7043
7044             my $fh = FileHandle->new;
7045             my $script_file = File::Spec->catfile($build_dir,$local_file);
7046             $fh->open($script_file)
7047                 or Carp::croak("Could not open script '$script_file': $!");
7048             local $/ = "\n";
7049             # name parsen und prereq
7050             my($state) = "poddir";
7051             my($name, $prereq) = ("", "");
7052             while (<$fh>) {
7053                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
7054                     if ($1 eq 'NAME') {
7055                         $state = "name";
7056                     } elsif ($1 eq 'PREREQUISITES') {
7057                         $state = "prereq";
7058                     }
7059                 } elsif ($state =~ m{^(name|prereq)$}) {
7060                     if (/^=/) {
7061                         $state = "poddir";
7062                     } elsif (/^\s*$/) {
7063                         # nop
7064                     } elsif ($state eq "name") {
7065                         if ($name eq "") {
7066                             ($name) = /^(\S+)/;
7067                             $state = "poddir";
7068                         }
7069                     } elsif ($state eq "prereq") {
7070                         $prereq .= $_;
7071                     }
7072                 } elsif (/^=cut\b/) {
7073                     last;
7074                 }
7075             }
7076             $fh->close;
7077
7078             for ($name) {
7079                 s{.*<}{};       # strip X<...>
7080                 s{>.*}{};
7081             }
7082             chomp $prereq;
7083             $prereq = join " ", split /\s+/, $prereq;
7084             my($PREREQ_PM) = join("\n", map {
7085                 s{.*<}{};       # strip X<...>
7086                 s{>.*}{};
7087                 if (/[\s\'\"]/) { # prose?
7088                 } else {
7089                     s/[^\w:]$//; # period?
7090                     " "x28 . "'$_' => 0,";
7091                 }
7092             } split /\s*,\s*/, $prereq);
7093
7094             if ($name) {
7095                 my $to_file = File::Spec->catfile($build_dir, $name);
7096                 rename $script_file, $to_file
7097                     or die "Can't rename $script_file to $to_file: $!";
7098             }
7099
7100     return "
7101               EXE_FILES => ['$name'],
7102               PREREQ_PM => {
7103 $PREREQ_PM
7104                            },
7105 ";
7106 }
7107
7108 #-> CPAN::Distribution::_signature_business
7109 sub _signature_business {
7110     my($self) = @_;
7111     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7112                                                       q{check_sigs});
7113     if ($check_sigs) {
7114         if ($CPAN::META->has_inst("Module::Signature")) {
7115             if (-f "SIGNATURE") {
7116                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7117                 my $rv = Module::Signature::verify();
7118                 if ($rv != Module::Signature::SIGNATURE_OK() and
7119                     $rv != Module::Signature::SIGNATURE_MISSING()) {
7120                     $CPAN::Frontend->mywarn(
7121                                             qq{\nSignature invalid for }.
7122                                             qq{distribution file. }.
7123                                             qq{Please investigate.\n\n}
7124                                            );
7125
7126                     my $wrap =
7127                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
7128                                 qq{while checking its signature, so it could        }.
7129                                 qq{be invalid. Maybe you have configured            }.
7130                                 qq{your 'urllist' with a bad URL. Please check this }.
7131                                 qq{array with 'o conf urllist' and retry. Or        }.
7132                                 qq{examine the distribution in a subshell. Try
7133   look %s
7134 and run
7135   cpansign -v
7136 },
7137                                 $self->{localfile},
7138                                 $self->pretty_id,
7139                                );
7140                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
7141                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
7142                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
7143                 } else {
7144                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
7145                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
7146                 }
7147             } else {
7148                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
7149             }
7150         } else {
7151             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7152         }
7153     }
7154 }
7155
7156 #-> CPAN::Distribution::untar_me ;
7157 sub untar_me {
7158     my($self,$ct) = @_;
7159     $self->{archived} = "tar";
7160     my $result = eval { $ct->untar() };
7161     if ($result) {
7162         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7163     } else {
7164         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
7165     }
7166 }
7167
7168 # CPAN::Distribution::unzip_me ;
7169 sub unzip_me {
7170     my($self,$ct) = @_;
7171     $self->{archived} = "zip";
7172     if ($ct->unzip()) {
7173         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7174     } else {
7175         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
7176     }
7177     return;
7178 }
7179
7180 sub handle_singlefile {
7181     my($self,$local_file) = @_;
7182
7183     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
7184         $self->{archived} = "pm";
7185     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
7186         $self->{archived} = "patch";
7187     } else {
7188         $self->{archived} = "maybe_pl";
7189     }
7190
7191     my $to = File::Basename::basename($local_file);
7192     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
7193         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
7194             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7195         } else {
7196             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
7197         }
7198     } else {
7199         if (File::Copy::cp($local_file,".")) {
7200             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7201         } else {
7202             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
7203         }
7204     }
7205     return $to;
7206 }
7207
7208 #-> sub CPAN::Distribution::new ;
7209 sub new {
7210     my($class,%att) = @_;
7211
7212     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
7213
7214     my $this = { %att };
7215     return bless $this, $class;
7216 }
7217
7218 #-> sub CPAN::Distribution::look ;
7219 sub look {
7220     my($self) = @_;
7221
7222     if ($^O eq 'MacOS') {
7223       $self->Mac::BuildTools::look;
7224       return;
7225     }
7226
7227     if (  $CPAN::Config->{'shell'} ) {
7228         $CPAN::Frontend->myprint(qq{
7229 Trying to open a subshell in the build directory...
7230 });
7231     } else {
7232         $CPAN::Frontend->myprint(qq{
7233 Your configuration does not define a value for subshells.
7234 Please define it with "o conf shell <your shell>"
7235 });
7236         return;
7237     }
7238     my $dist = $self->id;
7239     my $dir;
7240     unless ($dir = $self->dir) {
7241         $self->get;
7242     }
7243     unless ($dir ||= $self->dir) {
7244         $CPAN::Frontend->mywarn(qq{
7245 Could not determine which directory to use for looking at $dist.
7246 });
7247         return;
7248     }
7249     my $pwd  = CPAN::anycwd();
7250     $self->safe_chdir($dir);
7251     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
7252     {
7253         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
7254         $ENV{CPAN_SHELL_LEVEL} += 1;
7255         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
7256
7257         local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7258             ? $ENV{PERL5LIB}
7259                 : ($ENV{PERLLIB} || "");
7260
7261         local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
7262         $CPAN::META->set_perl5lib;
7263         local $ENV{MAKEFLAGS}; # protect us from outer make calls
7264
7265         unless (system($shell) == 0) {
7266             my $code = $? >> 8;
7267             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
7268         }
7269     }
7270     $self->safe_chdir($pwd);
7271 }
7272
7273 # CPAN::Distribution::cvs_import ;
7274 sub cvs_import {
7275     my($self) = @_;
7276     $self->get;
7277     my $dir = $self->dir;
7278
7279     my $package = $self->called_for;
7280     my $module = $CPAN::META->instance('CPAN::Module', $package);
7281     my $version = $module->cpan_version;
7282
7283     my $userid = $self->cpan_userid;
7284
7285     my $cvs_dir = (split /\//, $dir)[-1];
7286     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
7287     my $cvs_root =
7288       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
7289     my $cvs_site_perl =
7290       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
7291     if ($cvs_site_perl) {
7292         $cvs_dir = "$cvs_site_perl/$cvs_dir";
7293     }
7294     my $cvs_log = qq{"imported $package $version sources"};
7295     $version =~ s/\./_/g;
7296     # XXX cvs: undocumented and unclear how it was meant to work
7297     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
7298                "$cvs_dir", $userid, "v$version");
7299
7300     my $pwd  = CPAN::anycwd();
7301     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
7302
7303     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
7304
7305     $CPAN::Frontend->myprint(qq{@cmd\n});
7306     system(@cmd) == 0 or
7307     # XXX cvs
7308         $CPAN::Frontend->mydie("cvs import failed");
7309     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
7310 }
7311
7312 #-> sub CPAN::Distribution::readme ;
7313 sub readme {
7314     my($self) = @_;
7315     my($dist) = $self->id;
7316     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
7317     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
7318     my($local_file);
7319     my($local_wanted) =
7320         File::Spec->catfile(
7321                             $CPAN::Config->{keep_source_where},
7322                             "authors",
7323                             "id",
7324                             split(/\//,"$sans.readme"),
7325                            );
7326     $self->debug("Doing localize") if $CPAN::DEBUG;
7327     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
7328                                       $local_wanted)
7329         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
7330
7331     if ($^O eq 'MacOS') {
7332         Mac::BuildTools::launch_file($local_file);
7333         return;
7334     }
7335
7336     my $fh_pager = FileHandle->new;
7337     local($SIG{PIPE}) = "IGNORE";
7338     my $pager = $CPAN::Config->{'pager'} || "cat";
7339     $fh_pager->open("|$pager")
7340         or die "Could not open pager $pager\: $!";
7341     my $fh_readme = FileHandle->new;
7342     $fh_readme->open($local_file)
7343         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
7344     $CPAN::Frontend->myprint(qq{
7345 Displaying file
7346   $local_file
7347 with pager "$pager"
7348 });
7349     $fh_pager->print(<$fh_readme>);
7350     $fh_pager->close;
7351 }
7352
7353 #-> sub CPAN::Distribution::verifyCHECKSUM ;
7354 sub verifyCHECKSUM {
7355     my($self) = @_;
7356   EXCUSE: {
7357         my @e;
7358         $self->{CHECKSUM_STATUS} ||= "";
7359         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
7360         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7361     }
7362     my($lc_want,$lc_file,@local,$basename);
7363     @local = split(/\//,$self->id);
7364     pop @local;
7365     push @local, "CHECKSUMS";
7366     $lc_want =
7367         File::Spec->catfile($CPAN::Config->{keep_source_where},
7368                             "authors", "id", @local);
7369     local($") = "/";
7370     if (my $size = -s $lc_want) {
7371         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7372         if ($self->CHECKSUM_check_file($lc_want,1)) {
7373             return $self->{CHECKSUM_STATUS} = "OK";
7374         }
7375     }
7376     $lc_file = CPAN::FTP->localize("authors/id/@local",
7377                                    $lc_want,1);
7378     unless ($lc_file) {
7379         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7380         $local[-1] .= ".gz";
7381         $lc_file = CPAN::FTP->localize("authors/id/@local",
7382                                        "$lc_want.gz",1);
7383         if ($lc_file) {
7384             $lc_file =~ s/\.gz(?!\n)\Z//;
7385             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7386         } else {
7387             return;
7388         }
7389     }
7390     if ($self->CHECKSUM_check_file($lc_file)) {
7391         return $self->{CHECKSUM_STATUS} = "OK";
7392     }
7393 }
7394
7395 #-> sub CPAN::Distribution::SIG_check_file ;
7396 sub SIG_check_file {
7397     my($self,$chk_file) = @_;
7398     my $rv = eval { Module::Signature::_verify($chk_file) };
7399
7400     if ($rv == Module::Signature::SIGNATURE_OK()) {
7401         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7402         return $self->{SIG_STATUS} = "OK";
7403     } else {
7404         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7405                                  qq{distribution file. }.
7406                                  qq{Please investigate.\n\n}.
7407                                  $self->as_string,
7408                                  $CPAN::META->instance(
7409                                                        'CPAN::Author',
7410                                                        $self->cpan_userid
7411                                                       )->as_string);
7412
7413         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7414 is invalid. Maybe you have configured your 'urllist' with
7415 a bad URL. Please check this array with 'o conf urllist', and
7416 retry.};
7417
7418         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7419     }
7420 }
7421
7422 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7423
7424 # sloppy is 1 when we have an old checksums file that maybe is good
7425 # enough
7426
7427 sub CHECKSUM_check_file {
7428     my($self,$chk_file,$sloppy) = @_;
7429     my($cksum,$file,$basename);
7430
7431     $sloppy ||= 0;
7432     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7433     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7434                                                       q{check_sigs});
7435     if ($check_sigs) {
7436         if ($CPAN::META->has_inst("Module::Signature")) {
7437             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7438             $self->SIG_check_file($chk_file);
7439         } else {
7440             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7441         }
7442     }
7443
7444     $file = $self->{localfile};
7445     $basename = File::Basename::basename($file);
7446     my $fh = FileHandle->new;
7447     if (open $fh, $chk_file) {
7448         local($/);
7449         my $eval = <$fh>;
7450         $eval =~ s/\015?\012/\n/g;
7451         close $fh;
7452         my($compmt) = Safe->new();
7453         $cksum = $compmt->reval($eval);
7454         if ($@) {
7455             rename $chk_file, "$chk_file.bad";
7456             Carp::confess($@) if $@;
7457         }
7458     } else {
7459         Carp::carp "Could not open $chk_file for reading";
7460     }
7461
7462     if (! ref $cksum or ref $cksum ne "HASH") {
7463         $CPAN::Frontend->mywarn(qq{
7464 Warning: checksum file '$chk_file' broken.
7465
7466 When trying to read that file I expected to get a hash reference
7467 for further processing, but got garbage instead.
7468 });
7469         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7470         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7471         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7472         return;
7473     } elsif (exists $cksum->{$basename}{sha256}) {
7474         $self->debug("Found checksum for $basename:" .
7475                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7476
7477         open($fh, $file);
7478         binmode $fh;
7479         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7480         $fh->close;
7481         $fh = CPAN::Tarzip->TIEHANDLE($file);
7482
7483         unless ($eq) {
7484             my $dg = Digest::SHA->new(256);
7485             my($data,$ref);
7486             $ref = \$data;
7487             while ($fh->READ($ref, 4096) > 0) {
7488                 $dg->add($data);
7489             }
7490             my $hexdigest = $dg->hexdigest;
7491             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7492         }
7493
7494         if ($eq) {
7495             $CPAN::Frontend->myprint("Checksum for $file ok\n");
7496             return $self->{CHECKSUM_STATUS} = "OK";
7497         } else {
7498             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7499                                      qq{distribution file. }.
7500                                      qq{Please investigate.\n\n}.
7501                                      $self->as_string,
7502                                      $CPAN::META->instance(
7503                                                            'CPAN::Author',
7504                                                            $self->cpan_userid
7505                                                           )->as_string);
7506
7507             my $wrap = qq{I\'d recommend removing $file. Its
7508 checksum is incorrect. Maybe you have configured your 'urllist' with
7509 a bad URL. Please check this array with 'o conf urllist', and
7510 retry.};
7511
7512             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7513
7514             # former versions just returned here but this seems a
7515             # serious threat that deserves a die
7516
7517             # $CPAN::Frontend->myprint("\n\n");
7518             # sleep 3;
7519             # return;
7520         }
7521         # close $fh if fileno($fh);
7522     } else {
7523         return if $sloppy;
7524         unless ($self->{CHECKSUM_STATUS}) {
7525             $CPAN::Frontend->mywarn(qq{
7526 Warning: No checksum for $basename in $chk_file.
7527
7528 The cause for this may be that the file is very new and the checksum
7529 has not yet been calculated, but it may also be that something is
7530 going awry right now.
7531 });
7532             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7533             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7534         }
7535         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7536         return;
7537     }
7538 }
7539
7540 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7541 sub eq_CHECKSUM {
7542     my($self,$fh,$expect) = @_;
7543     if ($CPAN::META->has_inst("Digest::SHA")) {
7544         my $dg = Digest::SHA->new(256);
7545         my($data);
7546         while (read($fh, $data, 4096)) {
7547             $dg->add($data);
7548         }
7549         my $hexdigest = $dg->hexdigest;
7550         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7551         return $hexdigest eq $expect;
7552     }
7553     return 1;
7554 }
7555
7556 #-> sub CPAN::Distribution::force ;
7557
7558 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7559 # effect by autoinspection, not by inspecting a global variable. One
7560 # of the reason why this was chosen to work that way was the treatment
7561 # of dependencies. They should not automatically inherit the force
7562 # status. But this has the downside that ^C and die() will return to
7563 # the prompt but will not be able to reset the force_update
7564 # attributes. We try to correct for it currently in the read_metadata
7565 # routine, and immediately before we check for a Signal. I hope this
7566 # works out in one of v1.57_53ff
7567
7568 # "Force get forgets previous error conditions"
7569
7570 #-> sub CPAN::Distribution::fforce ;
7571 sub fforce {
7572   my($self, $method) = @_;
7573   $self->force($method,1);
7574 }
7575
7576 #-> sub CPAN::Distribution::force ;
7577 sub force {
7578   my($self, $method,$fforce) = @_;
7579   my %phase_map = (
7580                    get => [
7581                            "unwrapped",
7582                            "build_dir",
7583                            "archived",
7584                            "localfile",
7585                            "CHECKSUM_STATUS",
7586                            "signature_verify",
7587                            "prefs",
7588                            "prefs_file",
7589                            "prefs_file_doc",
7590                           ],
7591                    make => [
7592                             "writemakefile",
7593                             "make",
7594                             "modulebuild",
7595                             "prereq_pm",
7596                             "prereq_pm_detected",
7597                            ],
7598                    test => [
7599                             "badtestcnt",
7600                             "make_test",
7601                            ],
7602                    install => [
7603                                "install",
7604                               ],
7605                    unknown => [
7606                                "reqtype",
7607                                "yaml_content",
7608                               ],
7609                   );
7610   my $methodmatch = 0;
7611   my $ldebug = 0;
7612  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7613       $methodmatch = 1 if $fforce || $phase eq $method;
7614       next unless $methodmatch;
7615     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7616           if ($phase eq "get") {
7617               if (substr($self->id,-1,1) eq "."
7618                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
7619                   # cannot be undone for local distros
7620                   next ATTRIBUTE;
7621               }
7622               if ($att eq "build_dir"
7623                   && $self->{build_dir}
7624                   && $CPAN::META->{is_tested}
7625                  ) {
7626                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
7627               }
7628           } elsif ($phase eq "test") {
7629               if ($att eq "make_test"
7630                   && $self->{make_test}
7631                   && $self->{make_test}{COMMANDID}
7632                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7633                  ) {
7634                   # endless loop too likely
7635                   next ATTRIBUTE;
7636               }
7637           }
7638           delete $self->{$att};
7639           if ($ldebug || $CPAN::DEBUG) {
7640               # local $CPAN::DEBUG = 16; # Distribution
7641               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7642           }
7643       }
7644   }
7645   if ($method && $method =~ /make|test|install/) {
7646     $self->{force_update} = 1; # name should probably have been force_install
7647   }
7648 }
7649
7650 #-> sub CPAN::Distribution::notest ;
7651 sub notest {
7652   my($self, $method) = @_;
7653   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7654   $self->{"notest"}++; # name should probably have been force_install
7655 }
7656
7657 #-> sub CPAN::Distribution::unnotest ;
7658 sub unnotest {
7659   my($self) = @_;
7660   # warn "XDEBUG: deleting notest";
7661   delete $self->{notest};
7662 }
7663
7664 #-> sub CPAN::Distribution::unforce ;
7665 sub unforce {
7666   my($self) = @_;
7667   delete $self->{force_update};
7668 }
7669
7670 #-> sub CPAN::Distribution::isa_perl ;
7671 sub isa_perl {
7672   my($self) = @_;
7673   my $file = File::Basename::basename($self->id);
7674   if ($file =~ m{ ^ perl
7675                   -?
7676                   (5)
7677                   ([._-])
7678                   (
7679                    \d{3}(_[0-4][0-9])?
7680                    |
7681                    \d+\.\d+
7682                   )
7683                   \.tar[._-](?:gz|bz2)
7684                   (?!\n)\Z
7685                 }xs) {
7686     return "$1.$3";
7687   } elsif ($self->cpan_comment
7688            &&
7689            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7690     return $1;
7691   }
7692 }
7693
7694
7695 #-> sub CPAN::Distribution::perl ;
7696 sub perl {
7697     my ($self) = @_;
7698     if (! $self) {
7699         use Carp qw(carp);
7700         carp __PACKAGE__ . "::perl was called without parameters.";
7701     }
7702     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7703 }
7704
7705
7706 #-> sub CPAN::Distribution::make ;
7707 sub make {
7708     my($self) = @_;
7709     if (my $goto = $self->prefs->{goto}) {
7710         return $self->goto($goto);
7711     }
7712     my $make = $self->{modulebuild} ? "Build" : "make";
7713     # Emergency brake if they said install Pippi and get newest perl
7714     if ($self->isa_perl) {
7715         if (
7716             $self->called_for ne $self->id &&
7717             ! $self->{force_update}
7718         ) {
7719             # if we die here, we break bundles
7720             $CPAN::Frontend
7721                 ->mywarn(sprintf(
7722                             qq{The most recent version "%s" of the module "%s"
7723 is part of the perl-%s distribution. To install that, you need to run
7724   force install %s   --or--
7725   install %s
7726 },
7727                              $CPAN::META->instance(
7728                                                    'CPAN::Module',
7729                                                    $self->called_for
7730                                                   )->cpan_version,
7731                              $self->called_for,
7732                              $self->isa_perl,
7733                              $self->called_for,
7734                              $self->id,
7735                             ));
7736             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7737             $CPAN::Frontend->mysleep(1);
7738             return;
7739         }
7740     }
7741     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7742     $self->get;
7743     return if $self->prefs->{disabled} && ! $self->{force_update};
7744     if ($self->{configure_requires_later}) {
7745         return;
7746     }
7747     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7748                            ? $ENV{PERL5LIB}
7749                            : ($ENV{PERLLIB} || "");
7750     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
7751     $CPAN::META->set_perl5lib;
7752     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7753
7754     if ($CPAN::Signal) {
7755         delete $self->{force_update};
7756         return;
7757     }
7758
7759     my $builddir;
7760   EXCUSE: {
7761         my @e;
7762         if (!$self->{archived} || $self->{archived} eq "NO") {
7763             push @e, "Is neither a tar nor a zip archive.";
7764         }
7765
7766         if (!$self->{unwrapped}
7767             || (
7768                 UNIVERSAL::can($self->{unwrapped},"failed") ?
7769                 $self->{unwrapped}->failed :
7770                 $self->{unwrapped} =~ /^NO/
7771                )) {
7772             push @e, "Had problems unarchiving. Please build manually";
7773         }
7774
7775         unless ($self->{force_update}) {
7776             exists $self->{signature_verify} and
7777                 (
7778                  UNIVERSAL::can($self->{signature_verify},"failed") ?
7779                  $self->{signature_verify}->failed :
7780                  $self->{signature_verify} =~ /^NO/
7781                 )
7782                 and push @e, "Did not pass the signature test.";
7783         }
7784
7785         if (exists $self->{writemakefile} &&
7786             (
7787              UNIVERSAL::can($self->{writemakefile},"failed") ?
7788              $self->{writemakefile}->failed :
7789              $self->{writemakefile} =~ /^NO/
7790             )) {
7791             # XXX maybe a retry would be in order?
7792             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7793                 $self->{writemakefile}->text :
7794                     $self->{writemakefile};
7795             $err =~ s/^NO\s*(--\s+)?//;
7796             $err ||= "Had some problem writing Makefile";
7797             $err .= ", won't make";
7798             push @e, $err;
7799         }
7800
7801         if (defined $self->{make}) {
7802             if (UNIVERSAL::can($self->{make},"failed") ?
7803                 $self->{make}->failed :
7804                 $self->{make} =~ /^NO/) {
7805                 if ($self->{force_update}) {
7806                     # Trying an already failed 'make' (unless somebody else blocks)
7807                 } else {
7808                     # introduced for turning recursion detection into a distrostatus
7809                     my $error = length $self->{make}>3
7810                         ? substr($self->{make},3) : "Unknown error";
7811                     $CPAN::Frontend->mywarn("Could not make: $error\n");
7812                     $self->store_persistent_state;
7813                     return;
7814                 }
7815             } else {
7816                 push @e, "Has already been made";
7817                 my $wait_for_prereqs = eval { $self->satisfy_requires };
7818                 return 1 if $wait_for_prereqs;   # tells queuerunner to continue
7819                 return $self->goodbye($@) if $@; # tells queuerunner to stop
7820             }
7821         }
7822
7823         my $later = $self->{later} || $self->{configure_requires_later};
7824         if ($later) { # see also undelay
7825             if ($later) {
7826                 push @e, $later;
7827             }
7828         }
7829
7830         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7831         $builddir = $self->dir or
7832             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7833         unless (chdir $builddir) {
7834             push @e, "Couldn't chdir to '$builddir': $!";
7835         }
7836         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7837     }
7838     if ($CPAN::Signal) {
7839         delete $self->{force_update};
7840         return;
7841     }
7842     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7843     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7844
7845     if ($^O eq 'MacOS') {
7846         Mac::BuildTools::make($self);
7847         return;
7848     }
7849
7850     my %env;
7851     while (my($k,$v) = each %ENV) {
7852         next unless defined $v;
7853         $env{$k} = $v;
7854     }
7855     local %ENV = %env;
7856     my $system;
7857     my $pl_commandline;
7858     if ($self->prefs->{pl}) {
7859         $pl_commandline = $self->prefs->{pl}{commandline};
7860     }
7861     if ($pl_commandline) {
7862         $system = $pl_commandline;
7863         $ENV{PERL} = $^X;
7864     } elsif ($self->{'configure'}) {
7865         $system = $self->{'configure'};
7866     } elsif ($self->{modulebuild}) {
7867         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7868         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7869     } else {
7870         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7871         my $switch = "";
7872 # This needs a handler that can be turned on or off:
7873 #        $switch = "-MExtUtils::MakeMaker ".
7874 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7875 #            if $] > 5.00310;
7876         my $makepl_arg = $self->_make_phase_arg("pl");
7877         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7878                                                             "Makefile.PL");
7879         $system = sprintf("%s%s Makefile.PL%s",
7880                           $perl,
7881                           $switch ? " $switch" : "",
7882                           $makepl_arg ? " $makepl_arg" : "",
7883                          );
7884     }
7885     my $pl_env;
7886     if ($self->prefs->{pl}) {
7887         $pl_env = $self->prefs->{pl}{env};
7888     }
7889     if ($pl_env) {
7890         for my $e (keys %$pl_env) {
7891             $ENV{$e} = $pl_env->{$e};
7892         }
7893     }
7894     if (exists $self->{writemakefile}) {
7895     } else {
7896         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7897         my($ret,$pid,$output);
7898         $@ = "";
7899         my $go_via_alarm;
7900         if ($CPAN::Config->{inactivity_timeout}) {
7901             require Config;
7902             if ($Config::Config{d_alarm}
7903                 &&
7904                 $Config::Config{d_alarm} eq "define"
7905                ) {
7906                 $go_via_alarm++
7907             } else {
7908                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7909                                         "variable 'inactivity_timeout' to ".
7910                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7911                                         "on this machine the system call 'alarm' ".
7912                                         "isn't available. This means that we cannot ".
7913                                         "provide the feature of intercepting long ".
7914                                         "waiting code and will turn this feature off.\n"
7915                                        );
7916                 $CPAN::Config->{inactivity_timeout} = 0;
7917             }
7918         }
7919         if ($go_via_alarm) {
7920             if ( $self->_should_report('pl') ) {
7921                 ($output, $ret) = CPAN::Reporter::record_command(
7922                     $system,
7923                     $CPAN::Config->{inactivity_timeout},
7924                 );
7925                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7926             }
7927             else {
7928                 eval {
7929                     alarm $CPAN::Config->{inactivity_timeout};
7930                     local $SIG{CHLD}; # = sub { wait };
7931                     if (defined($pid = fork)) {
7932                         if ($pid) { #parent
7933                             # wait;
7934                             waitpid $pid, 0;
7935                         } else {    #child
7936                             # note, this exec isn't necessary if
7937                             # inactivity_timeout is 0. On the Mac I'd
7938                             # suggest, we set it always to 0.
7939                             exec $system;
7940                         }
7941                     } else {
7942                         $CPAN::Frontend->myprint("Cannot fork: $!");
7943                         return;
7944                     }
7945                 };
7946                 alarm 0;
7947                 if ($@) {
7948                     kill 9, $pid;
7949                     waitpid $pid, 0;
7950                     my $err = "$@";
7951                     $CPAN::Frontend->myprint($err);
7952                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7953                     $@ = "";
7954                     $self->store_persistent_state;
7955                     return $self->goodbye("$system -- TIMED OUT");
7956                 }
7957             }
7958         } else {
7959             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7960                 # XXX probably want to check _should_report here and warn
7961                 # about not being able to use CPAN::Reporter with expect
7962                 $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
7963                 if (! defined $ret
7964                     && $self->{writemakefile}
7965                     && $self->{writemakefile}->failed) {
7966                     # timeout
7967                     return;
7968                 }
7969             }
7970             elsif ( $self->_should_report('pl') ) {
7971                 ($output, $ret) = CPAN::Reporter::record_command($system);
7972                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7973             }
7974             else {
7975                 $ret = system($system);
7976             }
7977             if ($ret != 0) {
7978                 $self->{writemakefile} = CPAN::Distrostatus
7979                     ->new("NO '$system' returned status $ret");
7980                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7981                 $self->store_persistent_state;
7982                 return $self->goodbye("$system -- NOT OK");
7983             }
7984         }
7985         if (-f "Makefile" || -f "Build") {
7986             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7987             delete $self->{make_clean}; # if cleaned before, enable next
7988         } else {
7989             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7990             my $why = "No '$makefile' created";
7991             $CPAN::Frontend->mywarn($why);
7992             $self->{writemakefile} = CPAN::Distrostatus
7993                 ->new(qq{NO -- $why\n});
7994             $self->store_persistent_state;
7995             return $self->goodbye("$system -- NOT OK");
7996         }
7997     }
7998     if ($CPAN::Signal) {
7999         delete $self->{force_update};
8000         return;
8001     }
8002     my $wait_for_prereqs = eval { $self->satisfy_requires };
8003     return 1 if $wait_for_prereqs;   # tells queuerunner to continue
8004     return $self->goodbye($@) if $@; # tells queuerunner to stop
8005     if ($CPAN::Signal) {
8006         delete $self->{force_update};
8007         return;
8008     }
8009     my $make_commandline;
8010     if ($self->prefs->{make}) {
8011         $make_commandline = $self->prefs->{make}{commandline};
8012     }
8013     if ($make_commandline) {
8014         $system = $make_commandline;
8015         $ENV{PERL} = CPAN::find_perl;
8016     } else {
8017         if ($self->{modulebuild}) {
8018             unless (-f "Build") {
8019                 my $cwd = CPAN::anycwd();
8020                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
8021                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
8022                 $CPAN::Frontend->mysleep(5);
8023             }
8024             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
8025         } else {
8026             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
8027         }
8028         $system =~ s/\s+$//;
8029         my $make_arg = $self->_make_phase_arg("make");
8030         $system = sprintf("%s%s",
8031                           $system,
8032                           $make_arg ? " $make_arg" : "",
8033                          );
8034     }
8035     my $make_env;
8036     if ($self->prefs->{make}) {
8037         $make_env = $self->prefs->{make}{env};
8038     }
8039     if ($make_env) { # overriding the local ENV of PL, not the outer
8040                      # ENV, but unlikely to be a risk
8041         for my $e (keys %$make_env) {
8042             $ENV{$e} = $make_env->{$e};
8043         }
8044     }
8045     my $expect_model = $self->_prefs_with_expect("make");
8046     my $want_expect = 0;
8047     if ( $expect_model && @{$expect_model->{talk}} ) {
8048         my $can_expect = $CPAN::META->has_inst("Expect");
8049         if ($can_expect) {
8050             $want_expect = 1;
8051         } else {
8052             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8053                                     "system()\n");
8054         }
8055     }
8056     my $system_ok;
8057     if ($want_expect) {
8058         # XXX probably want to check _should_report here and
8059         # warn about not being able to use CPAN::Reporter with expect
8060         $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
8061     }
8062     elsif ( $self->_should_report('make') ) {
8063         my ($output, $ret) = CPAN::Reporter::record_command($system);
8064         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
8065         $system_ok = ! $ret;
8066     }
8067     else {
8068         $system_ok = system($system) == 0;
8069     }
8070     $self->introduce_myself;
8071     if ( $system_ok ) {
8072         $CPAN::Frontend->myprint("  $system -- OK\n");
8073         $self->{make} = CPAN::Distrostatus->new("YES");
8074     } else {
8075         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
8076         $self->{make} = CPAN::Distrostatus->new("NO");
8077         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8078     }
8079     $self->store_persistent_state;
8080 }
8081
8082 # CPAN::Distribution::goodbye ;
8083 sub goodbye {
8084     my($self,$goodbye) = @_;
8085     my $id = $self->pretty_id;
8086     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
8087     return;
8088 }
8089
8090 # CPAN::Distribution::_run_via_expect ;
8091 sub _run_via_expect {
8092     my($self,$system,$phase,$expect_model) = @_;
8093     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
8094     if ($CPAN::META->has_inst("Expect")) {
8095         my $expo = Expect->new;  # expo Expect object;
8096         $expo->spawn($system);
8097         $expect_model->{mode} ||= "deterministic";
8098         if ($expect_model->{mode} eq "deterministic") {
8099             return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
8100         } elsif ($expect_model->{mode} eq "anyorder") {
8101             return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
8102         } else {
8103             die "Panic: Illegal expect mode: $expect_model->{mode}";
8104         }
8105     } else {
8106         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
8107         return system($system);
8108     }
8109 }
8110
8111 sub _run_via_expect_anyorder {
8112     my($self,$expo,$phase,$expect_model) = @_;
8113     my $timeout = $expect_model->{timeout} || 5;
8114     my $reuse = $expect_model->{reuse};
8115     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
8116     my $but = "";
8117     my $timeout_start = time;
8118   EXPECT: while () {
8119         my($eof,$ran_into_timeout);
8120         # XXX not up to the full power of expect. one could certainly
8121         # wrap all of the talk pairs into a single expect call and on
8122         # success tweak it and step ahead to the next question. The
8123         # current implementation unnecessarily limits itself to a
8124         # single match.
8125         my @match = $expo->expect(1,
8126                                   [ eof => sub {
8127                                         $eof++;
8128                                     } ],
8129                                   [ timeout => sub {
8130                                         $ran_into_timeout++;
8131                                     } ],
8132                                   -re => eval"qr{.}",
8133                                  );
8134         if ($match[2]) {
8135             $but .= $match[2];
8136         }
8137         $but .= $expo->clear_accum;
8138         if ($eof) {
8139             $expo->soft_close;
8140             return $expo->exitstatus();
8141         } elsif ($ran_into_timeout) {
8142             # warn "DEBUG: they are asking a question, but[$but]";
8143             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
8144                 my($next,$send) = @expectacopy[$i,$i+1];
8145                 my $regex = eval "qr{$next}";
8146                 # warn "DEBUG: will compare with regex[$regex].";
8147                 if ($but =~ /$regex/) {
8148                     # warn "DEBUG: will send send[$send]";
8149                     $expo->send($send);
8150                     # never allow reusing an QA pair unless they told us
8151                     splice @expectacopy, $i, 2 unless $reuse;
8152                     next EXPECT;
8153                 }
8154             }
8155             my $have_waited = time - $timeout_start;
8156             if ($have_waited < $timeout) {
8157                 # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
8158                 next EXPECT;
8159             }
8160             my $why = "could not answer a question during the dialog";
8161             $CPAN::Frontend->mywarn("Failing: $why\n");
8162             $self->{$phase} =
8163                 CPAN::Distrostatus->new("NO $why");
8164             return 0;
8165         }
8166     }
8167 }
8168
8169 sub _run_via_expect_deterministic {
8170     my($self,$expo,$phase,$expect_model) = @_;
8171     my $ran_into_timeout;
8172     my $ran_into_eof;
8173     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
8174     my $expecta = $expect_model->{talk};
8175   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
8176         my($re,$send) = @$expecta[$i,$i+1];
8177         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
8178         my $regex = eval "qr{$re}";
8179         $expo->expect($timeout,
8180                       [ eof => sub {
8181                             my $but = $expo->clear_accum;
8182                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
8183 expected[$regex]\nbut[$but]\n\n");
8184                             $ran_into_eof++;
8185                         } ],
8186                       [ timeout => sub {
8187                             my $but = $expo->clear_accum;
8188                             $CPAN::Frontend->mywarn("TIMEOUT
8189 expected[$regex]\nbut[$but]\n\n");
8190                             $ran_into_timeout++;
8191                         } ],
8192                       -re => $regex);
8193         if ($ran_into_timeout) {
8194             # note that the caller expects 0 for success
8195             $self->{$phase} =
8196                 CPAN::Distrostatus->new("NO timeout during expect dialog");
8197             return 0;
8198         } elsif ($ran_into_eof) {
8199             last EXPECT;
8200         }
8201         $expo->send($send);
8202     }
8203     $expo->soft_close;
8204     return $expo->exitstatus();
8205 }
8206
8207 #-> CPAN::Distribution::_validate_distropref
8208 sub _validate_distropref {
8209     my($self,@args) = @_;
8210     if (
8211         $CPAN::META->has_inst("CPAN::Kwalify")
8212         &&
8213         $CPAN::META->has_inst("Kwalify")
8214        ) {
8215         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
8216         if ($@) {
8217             $CPAN::Frontend->mywarn($@);
8218         }
8219     } else {
8220         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
8221     }
8222 }
8223
8224 #-> CPAN::Distribution::_find_prefs
8225 sub _find_prefs {
8226     my($self) = @_;
8227     my $distroid = $self->pretty_id;
8228     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
8229     my $prefs_dir = $CPAN::Config->{prefs_dir};
8230     return if $prefs_dir =~ /^\s*$/;
8231     eval { File::Path::mkpath($prefs_dir); };
8232     if ($@) {
8233         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
8234     }
8235     my $yaml_module = CPAN::_yaml_module;
8236     my $ext_map = {};
8237     my @extensions;
8238     if ($CPAN::META->has_inst($yaml_module)) {
8239         $ext_map->{yml} = 'CPAN';
8240     } else {
8241         my @fallbacks;
8242         if ($CPAN::META->has_inst("Data::Dumper")) {
8243             push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
8244         }
8245         if ($CPAN::META->has_inst("Storable")) {
8246             push @fallbacks, $ext_map->{st} = 'Storable';
8247         }
8248         if (@fallbacks) {
8249             local $" = " and ";
8250             unless ($self->{have_complained_about_missing_yaml}++) {
8251                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
8252                                         "to @fallbacks to read prefs '$prefs_dir'\n");
8253             }
8254         } else {
8255             unless ($self->{have_complained_about_missing_yaml}++) {
8256                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
8257                                         "read prefs '$prefs_dir'\n");
8258             }
8259         }
8260     }
8261     my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
8262     DIRENT: while (my $result = $finder->next) {
8263         if ($result->is_warning) {
8264             $CPAN::Frontend->mywarn($result->as_string);
8265             $CPAN::Frontend->mysleep(1);
8266             next DIRENT;
8267         } elsif ($result->is_fatal) {
8268             $CPAN::Frontend->mydie($result->as_string);
8269         }
8270
8271         my @prefs = @{ $result->prefs };
8272
8273       ELEMENT: for my $y (0..$#prefs) {
8274             my $pref = $prefs[$y];
8275             $self->_validate_distropref($pref->data, $result->abs, $y);
8276
8277             # I don't know why we silently skip when there's no match, but
8278             # complain if there's an empty match hashref, and there's no
8279             # comment explaining why -- hdp, 2008-03-18
8280             unless ($pref->has_any_match) {
8281                 next ELEMENT;
8282             }
8283
8284             unless ($pref->has_valid_subkeys) {
8285                 $CPAN::Frontend->mydie(sprintf
8286                     "Nonconforming .%s file '%s': " .
8287                     "missing match/* subattribute. " .
8288                     "Please remove, cannot continue.",
8289                     $result->ext, $result->abs,
8290                 );
8291             }
8292
8293             my $arg = {
8294                 env          => \%ENV,
8295                 distribution => $distroid,
8296                 perl         => \&CPAN::find_perl,
8297                 perlconfig   => \%Config::Config,
8298                 module       => sub { [ $self->containsmods ] },
8299             };
8300
8301             if ($pref->matches($arg)) {
8302                 return {
8303                     prefs => $pref->data,
8304                     prefs_file => $result->abs,
8305                     prefs_file_doc => $y,
8306                 };
8307             }
8308
8309         }
8310     }
8311     return;
8312 }
8313
8314 # CPAN::Distribution::prefs
8315 sub prefs {
8316     my($self) = @_;
8317     if (exists $self->{negative_prefs_cache}
8318         &&
8319         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8320        ) {
8321         delete $self->{negative_prefs_cache};
8322         delete $self->{prefs};
8323     }
8324     if (exists $self->{prefs}) {
8325         return $self->{prefs}; # XXX comment out during debugging
8326     }
8327     if ($CPAN::Config->{prefs_dir}) {
8328         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8329         my $prefs = $self->_find_prefs();
8330         $prefs ||= ""; # avoid warning next line
8331         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8332         if ($prefs) {
8333             for my $x (qw(prefs prefs_file prefs_file_doc)) {
8334                 $self->{$x} = $prefs->{$x};
8335             }
8336             my $bs = sprintf(
8337                              "%s[%s]",
8338                              File::Basename::basename($self->{prefs_file}),
8339                              $self->{prefs_file_doc},
8340                             );
8341             my $filler1 = "_" x 22;
8342             my $filler2 = int(66 - length($bs))/2;
8343             $filler2 = 0 if $filler2 < 0;
8344             $filler2 = " " x $filler2;
8345             $CPAN::Frontend->myprint("
8346 $filler1 D i s t r o P r e f s $filler1
8347 $filler2 $bs $filler2
8348 ");
8349             $CPAN::Frontend->mysleep(1);
8350             return $self->{prefs};
8351         }
8352     }
8353     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8354     return $self->{prefs} = +{};
8355 }
8356
8357 # CPAN::Distribution::_make_phase_arg
8358 sub _make_phase_arg {
8359     my($self, $phase) = @_;
8360     my $_make_phase_arg;
8361     my $prefs = $self->prefs;
8362     if (
8363         $prefs
8364         && exists $prefs->{$phase}
8365         && exists $prefs->{$phase}{args}
8366         && $prefs->{$phase}{args}
8367        ) {
8368         $_make_phase_arg = join(" ",
8369                            map {CPAN::HandleConfig
8370                                  ->safe_quote($_)} @{$prefs->{$phase}{args}},
8371                           );
8372     }
8373
8374 # cpan[2]> o conf make[TAB]
8375 # make                       make_install_make_command
8376 # make_arg                   makepl_arg
8377 # make_install_arg
8378 # cpan[2]> o conf mbuild[TAB]
8379 # mbuild_arg                    mbuild_install_build_command
8380 # mbuild_install_arg            mbuildpl_arg
8381
8382     my $mantra; # must switch make/mbuild here
8383     if ($self->{modulebuild}) {
8384         $mantra = "mbuild";
8385     } else {
8386         $mantra = "make";
8387     }
8388     my %map = (
8389                pl => "pl_arg",
8390                make => "_arg",
8391                test => "_test_arg", # does not really exist but maybe
8392                                     # will some day and now protects
8393                                     # us from unini warnings
8394                install => "_install_arg",
8395               );
8396     my $phase_underscore_meshup = $map{$phase};
8397     my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
8398
8399     $_make_phase_arg ||= $CPAN::Config->{$what};
8400     return $_make_phase_arg;
8401 }
8402
8403 # CPAN::Distribution::_make_command
8404 sub _make_command {
8405     my ($self) = @_;
8406     if ($self) {
8407         return
8408             CPAN::HandleConfig
8409                 ->safe_quote(
8410                              CPAN::HandleConfig->prefs_lookup($self,
8411                                                               q{make})
8412                              || $Config::Config{make}
8413                              || 'make'
8414                             );
8415     } else {
8416         # Old style call, without object. Deprecated
8417         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8418         return
8419           safe_quote(undef,
8420                      CPAN::HandleConfig->prefs_lookup($self,q{make})
8421                      || $CPAN::Config->{make}
8422                      || $Config::Config{make}
8423                      || 'make');
8424     }
8425 }
8426
8427 #-> sub CPAN::Distribution::follow_prereqs ;
8428 sub follow_prereqs {
8429     my($self) = shift;
8430     my($slot) = shift;
8431     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8432     return unless @prereq_tuples;
8433     my(@good_prereq_tuples);
8434     for my $p (@prereq_tuples) {
8435         # XXX watch out for foul ones
8436         push @good_prereq_tuples, $p;
8437     }
8438     my $pretty_id = $self->pretty_id;
8439     my %map = (
8440                b => "build_requires",
8441                r => "requires",
8442                c => "commandline",
8443               );
8444     my($filler1,$filler2,$filler3,$filler4);
8445     my $unsat = "Unsatisfied dependencies detected during";
8446     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8447     {
8448         my $r = int(($w - length($unsat))/2);
8449         my $l = $w - length($unsat) - $r;
8450         $filler1 = "-"x4 . " "x$l;
8451         $filler2 = " "x$r . "-"x4 . "\n";
8452     }
8453     {
8454         my $r = int(($w - length($pretty_id))/2);
8455         my $l = $w - length($pretty_id) - $r;
8456         $filler3 = "-"x4 . " "x$l;
8457         $filler4 = " "x$r . "-"x4 . "\n";
8458     }
8459     $CPAN::Frontend->
8460         myprint("$filler1 $unsat $filler2".
8461                 "$filler3 $pretty_id $filler4".
8462                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
8463                );
8464     my $follow = 0;
8465     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8466         $follow = 1;
8467     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8468         my $answer = CPAN::Shell::colorable_makemaker_prompt(
8469 "Shall I follow them and prepend them to the queue
8470 of modules we are processing right now?", "yes");
8471         $follow = $answer =~ /^\s*y/i;
8472     } else {
8473         my @prereq = map { $_=>[0] } @good_prereq_tuples;
8474         local($") = ", ";
8475         $CPAN::Frontend->
8476             myprint("  Ignoring dependencies on modules @prereq\n");
8477     }
8478     if ($follow) {
8479         my $id = $self->id;
8480         # color them as dirty
8481         for my $gp (@good_prereq_tuples) {
8482             # warn "calling color_cmd_tmps(0,1)";
8483             my $p = $gp->[0];
8484             my $any = CPAN::Shell->expandany($p);
8485             $self->{$slot . "_for"}{$any->id}++;
8486             if ($any) {
8487                 $any->color_cmd_tmps(0,2);
8488             } else {
8489                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8490                 $CPAN::Frontend->mysleep(2);
8491             }
8492         }
8493         # queue them and re-queue yourself
8494         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8495                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
8496         $self->{$slot} = "Delayed until after prerequisites";
8497         return 1; # signal success to the queuerunner
8498     }
8499     return;
8500 }
8501
8502 sub _feature_depends {
8503     my($self) = @_;
8504     my $meta_yml = $self->parse_meta_yml();
8505     my $optf = $meta_yml->{optional_features} or return;
8506     if (!ref $optf or ref $optf ne "HASH"){
8507         $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
8508         $optf = {};
8509     }
8510     my $wantf = $self->prefs->{features} or return;
8511     if (!ref $wantf or ref $wantf ne "ARRAY"){
8512         $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
8513         $wantf = [];
8514     }
8515     my $dep = +{};
8516     for my $wf (@$wantf) {
8517         if (my $f = $optf->{$wf}) {
8518             $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
8519                                      "is accompanied by this description:\n".
8520                                      $f->{description}.
8521                                      "\n\n"
8522                                     );
8523             # configure_requires currently not in the spec, unlikely to be useful anyway
8524             for my $reqtype (qw(configure_requires build_requires requires)) {
8525                 my $reqhash = $f->{$reqtype} or next;
8526                 while (my($k,$v) = each %$reqhash) {
8527                     $dep->{$reqtype}{$k} = $v;
8528                 }
8529             }
8530         } else {
8531             $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
8532                                     "found in the META.yml file".
8533                                     "\n\n"
8534                                    );
8535         }
8536     }
8537     $dep;
8538 }
8539
8540 #-> sub CPAN::Distribution::unsat_prereq ;
8541 # return ([Foo,"r"],[Bar,"b"]) for normal modules
8542 # return ([perl=>5.008]) if we need a newer perl than we are running under
8543 # (sorry for the inconsistency, it was an accident)
8544 sub unsat_prereq {
8545     my($self,$slot) = @_;
8546     my(%merged,$prereq_pm);
8547     my $prefs_depends = $self->prefs->{depends}||{};
8548     my $feature_depends = $self->_feature_depends();
8549     if ($slot eq "configure_requires_later") {
8550         my $meta_yml = $self->parse_meta_yml();
8551         if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
8552             $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
8553             $meta_yml = +{};
8554         }
8555         %merged = (
8556                    %{$meta_yml->{configure_requires}||{}},
8557                    %{$prefs_depends->{configure_requires}||{}},
8558                    %{$feature_depends->{configure_requires}||{}},
8559                   );
8560         $prereq_pm = {}; # configure_requires defined as "b"
8561     } elsif ($slot eq "later") {
8562         my $prereq_pm_0 = $self->prereq_pm || {};
8563         for my $reqtype (qw(requires build_requires)) {
8564             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8565             for my $dep ($prefs_depends,$feature_depends) {
8566                 for my $k (keys %{$dep->{$reqtype}||{}}) {
8567                     $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
8568                 }
8569             }
8570         }
8571         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8572     } else {
8573         die "Panic: illegal slot '$slot'";
8574     }
8575     my(@need);
8576     my @merged = %merged;
8577     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8578   NEED: while (my($need_module, $need_version) = each %merged) {
8579         my($available_version,$available_file,$nmo);
8580         if ($need_module eq "perl") {
8581             $available_version = $];
8582             $available_file = CPAN::find_perl;
8583         } else {
8584             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8585             next if $nmo->uptodate;
8586             $available_file = $nmo->available_file;
8587
8588             # if they have not specified a version, we accept any installed one
8589             if (defined $available_file
8590                 and ( # a few quick shortcurcuits
8591                      not defined $need_version
8592                      or $need_version eq '0'    # "==" would trigger warning when not numeric
8593                      or $need_version eq "undef"
8594                     )) {
8595                 next NEED;
8596             }
8597
8598             $available_version = $nmo->available_version;
8599         }
8600
8601         # We only want to install prereqs if either they're not installed
8602         # or if the installed version is too old. We cannot omit this
8603         # check, because if 'force' is in effect, nobody else will check.
8604         if (defined $available_file) {
8605             my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
8606                 ($need_module,$available_file,$available_version,$need_version);
8607             next NEED if $fulfills_all_version_rqs;
8608         }
8609
8610         if ($need_module eq "perl") {
8611             return ["perl", $need_version];
8612         }
8613         $self->{sponsored_mods}{$need_module} ||= 0;
8614         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8615         if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
8616             # We have already sponsored it and for some reason it's still
8617             # not available. So we do ... what??
8618
8619             # if we push it again, we have a potential infinite loop
8620
8621             # The following "next" was a very problematic construct.
8622             # It helped a lot but broke some day and had to be
8623             # replaced.
8624
8625             # We must be able to deal with modules that come again and
8626             # again as a prereq and have themselves prereqs and the
8627             # queue becomes long but finally we would find the correct
8628             # order. The RecursiveDependency check should trigger a
8629             # die when it's becoming too weird. Unfortunately removing
8630             # this next breaks many other things.
8631
8632             # The bug that brought this up is described in Todo under
8633             # "5.8.9 cannot install Compress::Zlib"
8634
8635             # next; # this is the next that had to go away
8636
8637             # The following "next NEED" are fine and the error message
8638             # explains well what is going on. For example when the DBI
8639             # fails and consequently DBD::SQLite fails and now we are
8640             # processing CPAN::SQLite. Then we must have a "next" for
8641             # DBD::SQLite. How can we get it and how can we identify
8642             # all other cases we must identify?
8643
8644             my $do = $nmo->distribution;
8645             next NEED unless $do; # not on CPAN
8646             if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
8647                 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8648                                         "'$need_module => $need_version' ".
8649                                         "for '$self->{ID}' seems ".
8650                                         "not available according to the indexes\n"
8651                                        );
8652                 next NEED;
8653             }
8654           NOSAYER: for my $nosayer (
8655                                     "unwrapped",
8656                                     "writemakefile",
8657                                     "signature_verify",
8658                                     "make",
8659                                     "make_test",
8660                                     "install",
8661                                     "make_clean",
8662                                    ) {
8663                 if ($do->{$nosayer}) {
8664                     my $selfid = $self->pretty_id;
8665                     my $did = $do->pretty_id;
8666                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8667                         $do->{$nosayer}->failed :
8668                         $do->{$nosayer} =~ /^NO/) {
8669                         if ($nosayer eq "make_test"
8670                             &&
8671                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8672                            ) {
8673                             next NOSAYER;
8674                         }
8675                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8676                                                 "'$need_module => $need_version' ".
8677                                                 "for '$selfid' failed when ".
8678                                                 "processing '$did' with ".
8679                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8680                                                 "but chances to succeed are limited.\n"
8681                                                );
8682                         $CPAN::Frontend->mysleep($sponsoring/10);
8683                         next NEED;
8684                     } else { # the other guy succeeded
8685                         if ($nosayer =~ /^(install|make_test)$/) {
8686                             # we had this with
8687                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8688                             # in 2007-03 for 'make install'
8689                             # and 2008-04: #30464 (for 'make test')
8690                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8691                                                     "'$need_module => $need_version' ".
8692                                                     "for '$selfid' already built ".
8693                                                     "but the result looks suspicious. ".
8694                                                     "Skipping another build attempt, ".
8695                                                     "to prevent looping endlessly.\n"
8696                                                    );
8697                             next NEED;
8698                         }
8699                     }
8700                 }
8701             }
8702         }
8703         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8704         push @need, [$need_module,$needed_as];
8705     }
8706     my @unfolded = map { "[".join(",",@$_)."]" } @need;
8707     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8708     @need;
8709 }
8710
8711 sub _fulfills_all_version_rqs {
8712     my($self,$need_module,$available_file,$available_version,$need_version) = @_;
8713     my(@all_requirements) = split /\s*,\s*/, $need_version;
8714     local($^W) = 0;
8715     my $ok = 0;
8716   RQ: for my $rq (@all_requirements) {
8717         if ($rq =~ s|>=\s*||) {
8718         } elsif ($rq =~ s|>\s*||) {
8719             # 2005-12: one user
8720             if (CPAN::Version->vgt($available_version,$rq)) {
8721                 $ok++;
8722             }
8723             next RQ;
8724         } elsif ($rq =~ s|!=\s*||) {
8725             # 2005-12: no user
8726             if (CPAN::Version->vcmp($available_version,$rq)) {
8727                 $ok++;
8728                 next RQ;
8729             } else {
8730                 last RQ;
8731             }
8732         } elsif ($rq =~ m|<=?\s*|) {
8733             # 2005-12: no user
8734             $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8735             $ok++;
8736             next RQ;
8737         }
8738         if (! CPAN::Version->vgt($rq, $available_version)) {
8739             $ok++;
8740         }
8741         CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8742                             "available_version[%s]rq[%s]ok[%d]",
8743                             $need_module,
8744                             $available_file,
8745                             $available_version,
8746                             CPAN::Version->readable($rq),
8747                             $ok,
8748                            )) if $CPAN::DEBUG;
8749     }
8750     return $ok == @all_requirements;
8751 }
8752
8753 #-> sub CPAN::Distribution::read_yaml ;
8754 sub read_yaml {
8755     my($self) = @_;
8756     return $self->{yaml_content} if exists $self->{yaml_content};
8757     my $build_dir;
8758     unless ($build_dir = $self->{build_dir}) {
8759         # maybe permission on build_dir was missing
8760         $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
8761         return;
8762     }
8763     my $yaml = File::Spec->catfile($build_dir,"META.yml");
8764     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8765     return unless -f $yaml;
8766     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8767     if ($@) {
8768         $CPAN::Frontend->mywarn("Could not read ".
8769                                 "'$yaml'. Falling back to other ".
8770                                 "methods to determine prerequisites\n");
8771         return $self->{yaml_content} = undef; # if we die, then we
8772                                               # cannot read YAML's own
8773                                               # META.yml
8774     }
8775     # not "authoritative"
8776     for ($self->{yaml_content}) {
8777         if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
8778             $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
8779             $self->{yaml_content} = +{};
8780         }
8781     }
8782     if (not exists $self->{yaml_content}{dynamic_config}
8783         or $self->{yaml_content}{dynamic_config}
8784        ) {
8785         $self->{yaml_content} = undef;
8786     }
8787     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8788         if $CPAN::DEBUG;
8789     return $self->{yaml_content};
8790 }
8791
8792 #-> sub CPAN::Distribution::prereq_pm ;
8793 sub prereq_pm {
8794     my($self) = @_;
8795     $self->{prereq_pm_detected} ||= 0;
8796     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8797     return $self->{prereq_pm} if $self->{prereq_pm_detected};
8798     return unless $self->{writemakefile}  # no need to have succeeded
8799                                           # but we must have run it
8800         || $self->{modulebuild};
8801     unless ($self->{build_dir}) {
8802         return;
8803     }
8804     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8805                 $self->{writemakefile}||"",
8806                 $self->{modulebuild}||"",
8807                ) if $CPAN::DEBUG;
8808     my($req,$breq);
8809     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8810         $req =  $yaml->{requires} || {};
8811         $breq =  $yaml->{build_requires} || {};
8812         undef $req unless ref $req eq "HASH" && %$req;
8813         if ($req) {
8814             if ($yaml->{generated_by} &&
8815                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8816                 my $eummv = do { local $^W = 0; $1+0; };
8817                 if ($eummv < 6.2501) {
8818                     # thanks to Slaven for digging that out: MM before
8819                     # that could be wrong because it could reflect a
8820                     # previous release
8821                     undef $req;
8822                 }
8823             }
8824             my $areq;
8825             my $do_replace;
8826             while (my($k,$v) = each %{$req||{}}) {
8827                 if ($v =~ /\d/) {
8828                     $areq->{$k} = $v;
8829                 } elsif ($k =~ /[A-Za-z]/ &&
8830                          $v =~ /[A-Za-z]/ &&
8831                          $CPAN::META->exists("Module",$v)
8832                         ) {
8833                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8834                                             "requires hash: $k => $v; I'll take both ".
8835                                             "key and value as a module name\n");
8836                     $CPAN::Frontend->mysleep(1);
8837                     $areq->{$k} = 0;
8838                     $areq->{$v} = 0;
8839                     $do_replace++;
8840                 }
8841             }
8842             $req = $areq if $do_replace;
8843         }
8844     }
8845     unless ($req || $breq) {
8846         my $build_dir;
8847         unless ( $build_dir = $self->{build_dir} ) {
8848             return;
8849         }
8850         my $makefile = File::Spec->catfile($build_dir,"Makefile");
8851         my $fh;
8852         if (-f $makefile
8853             and
8854             $fh = FileHandle->new("<$makefile\0")) {
8855             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8856             local($/) = "\n";
8857             while (<$fh>) {
8858                 last if /MakeMaker post_initialize section/;
8859                 my($p) = m{^[\#]
8860                            \s+PREREQ_PM\s+=>\s+(.+)
8861                        }x;
8862                 next unless $p;
8863                 # warn "Found prereq expr[$p]";
8864
8865                 #  Regexp modified by A.Speer to remember actual version of file
8866                 #  PREREQ_PM hash key wants, then add to
8867                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8868                     # In case a prereq is mentioned twice, complain.
8869                     if ( defined $req->{$1} ) {
8870                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
8871                             "last mention wins";
8872                     }
8873                     my($m,$n) = ($1,$2);
8874                     if ($n =~ /^q\[(.*?)\]$/) {
8875                         $n = $1;
8876                     }
8877                     $req->{$m} = $n;
8878                 }
8879                 last;
8880             }
8881         }
8882     }
8883     unless ($req || $breq) {
8884         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8885         my $buildfile = File::Spec->catfile($build_dir,"Build");
8886         if (-f $buildfile) {
8887             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8888             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8889             if (-f $build_prereqs) {
8890                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8891                 my $content = do { local *FH;
8892                                    open FH, $build_prereqs
8893                                        or $CPAN::Frontend->mydie("Could not open ".
8894                                                                  "'$build_prereqs': $!");
8895                                    local $/;
8896                                    <FH>;
8897                                };
8898                 my $bphash = eval $content;
8899                 if ($@) {
8900                 } else {
8901                     $req  = $bphash->{requires} || +{};
8902                     $breq = $bphash->{build_requires} || +{};
8903                 }
8904             }
8905         }
8906     }
8907     if (-f "Build.PL"
8908         && ! -f "Makefile.PL"
8909         && ! exists $req->{"Module::Build"}
8910         && ! $CPAN::META->has_inst("Module::Build")) {
8911         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8912                                 "undeclared prerequisite.\n".
8913                                 "  Adding it now as such.\n"
8914                                );
8915         $CPAN::Frontend->mysleep(5);
8916         $req->{"Module::Build"} = 0;
8917         delete $self->{writemakefile};
8918     }
8919     if ($req || $breq) {
8920         $self->{prereq_pm_detected}++;
8921         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8922     }
8923 }
8924
8925 #-> sub CPAN::Distribution::test ;
8926 sub test {
8927     my($self) = @_;
8928     if (my $goto = $self->prefs->{goto}) {
8929         return $self->goto($goto);
8930     }
8931     $self->make;
8932     return if $self->prefs->{disabled} && ! $self->{force_update};
8933     if ($CPAN::Signal) {
8934       delete $self->{force_update};
8935       return;
8936     }
8937     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8938     if ($self->{notest}) {
8939         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8940         return 1;
8941     }
8942
8943     my $make = $self->{modulebuild} ? "Build" : "make";
8944
8945     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8946                            ? $ENV{PERL5LIB}
8947                            : ($ENV{PERLLIB} || "");
8948
8949     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
8950     $CPAN::META->set_perl5lib;
8951     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8952
8953     $CPAN::Frontend->myprint("Running $make test\n");
8954
8955   EXCUSE: {
8956         my @e;
8957         if ($self->{make} or $self->{later}) {
8958             # go ahead
8959         } else {
8960             push @e,
8961                 "Make had some problems, won't test";
8962         }
8963
8964         exists $self->{make} and
8965             (
8966              UNIVERSAL::can($self->{make},"failed") ?
8967              $self->{make}->failed :
8968              $self->{make} =~ /^NO/
8969             ) and push @e, "Can't test without successful make";
8970         $self->{badtestcnt} ||= 0;
8971         if ($self->{badtestcnt} > 0) {
8972             require Data::Dumper;
8973             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8974             push @e, "Won't repeat unsuccessful test during this command";
8975         }
8976
8977         push @e, $self->{later} if $self->{later};
8978         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8979
8980         if (exists $self->{build_dir}) {
8981             if (exists $self->{make_test}) {
8982                 if (
8983                     UNIVERSAL::can($self->{make_test},"failed") ?
8984                     $self->{make_test}->failed :
8985                     $self->{make_test} =~ /^NO/
8986                    ) {
8987                     if (
8988                         UNIVERSAL::can($self->{make_test},"commandid")
8989                         &&
8990                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8991                        ) {
8992                         push @e, "Has already been tested within this command";
8993                     }
8994                 } else {
8995                     push @e, "Has already been tested successfully";
8996                     # if global "is_tested" has been cleared, we need to mark this to
8997                     # be added to PERL5LIB if not already installed
8998                     if ($self->tested_ok_but_not_installed) {
8999                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9000                     }
9001                 }
9002             }
9003         } elsif (!@e) {
9004             push @e, "Has no own directory";
9005         }
9006         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
9007         unless (chdir $self->{build_dir}) {
9008             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
9009         }
9010         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
9011     }
9012     $self->debug("Changed directory to $self->{build_dir}")
9013         if $CPAN::DEBUG;
9014
9015     if ($^O eq 'MacOS') {
9016         Mac::BuildTools::make_test($self);
9017         return;
9018     }
9019
9020     if ($self->{modulebuild}) {
9021         my $thm = CPAN::Shell->expand("Module","Test::Harness");
9022         my $v = $thm->inst_version;
9023         if (CPAN::Version->vlt($v,2.62)) {
9024             # XXX Eric Wilhelm reported this as a bug: klapperl:
9025             # Test::Harness 3.0 self-tests, so that should be 'unless
9026             # installing Test::Harness'
9027             unless ($self->id eq $thm->distribution->id) {
9028                $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
9029   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
9030                 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
9031                 return;
9032             }
9033         }
9034     }
9035
9036     if ( ! $self->{force_update}  ) {
9037         # bypass actual tests if "trust_test_report_history" and have a report
9038         my $have_tested_fcn;
9039         if (   $CPAN::Config->{trust_test_report_history}
9040             && $CPAN::META->has_inst("CPAN::Reporter::History")
9041             && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
9042             if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
9043                 # Do nothing if grade was DISCARD
9044                 if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
9045                     $self->{make_test} = CPAN::Distrostatus->new("YES");
9046                     # if global "is_tested" has been cleared, we need to mark this to
9047                     # be added to PERL5LIB if not already installed
9048                     if ($self->tested_ok_but_not_installed) {
9049                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9050                     }
9051                     $CPAN::Frontend->myprint("Found prior test report -- OK\n");
9052                     return;
9053                 }
9054                 elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
9055                     $self->{make_test} = CPAN::Distrostatus->new("NO");
9056                     $self->{badtestcnt}++;
9057                     $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
9058                     return;
9059                 }
9060             }
9061         }
9062     }
9063
9064     my $system;
9065     my $prefs_test = $self->prefs->{test};
9066     if (my $commandline
9067         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
9068         $system = $commandline;
9069         $ENV{PERL} = CPAN::find_perl;
9070     } elsif ($self->{modulebuild}) {
9071         $system = sprintf "%s test", $self->_build_command();
9072         unless (-e "Build") {
9073             my $id = $self->pretty_id;
9074             $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
9075         }
9076     } else {
9077         $system = join " ", $self->_make_command(), "test";
9078     }
9079     my $make_test_arg = $self->_make_phase_arg("test");
9080     $system = sprintf("%s%s",
9081                       $system,
9082                       $make_test_arg ? " $make_test_arg" : "",
9083                      );
9084     my($tests_ok);
9085     my %env;
9086     while (my($k,$v) = each %ENV) {
9087         next unless defined $v;
9088         $env{$k} = $v;
9089     }
9090     local %ENV = %env;
9091     my $test_env;
9092     if ($self->prefs->{test}) {
9093         $test_env = $self->prefs->{test}{env};
9094     }
9095     if ($test_env) {
9096         for my $e (keys %$test_env) {
9097             $ENV{$e} = $test_env->{$e};
9098         }
9099     }
9100     my $expect_model = $self->_prefs_with_expect("test");
9101     my $want_expect = 0;
9102     if ( $expect_model && @{$expect_model->{talk}} ) {
9103         my $can_expect = $CPAN::META->has_inst("Expect");
9104         if ($can_expect) {
9105             $want_expect = 1;
9106         } else {
9107             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
9108                                     "testing without\n");
9109         }
9110     }
9111     if ($want_expect) {
9112         if ($self->_should_report('test')) {
9113             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
9114                                     "not supported when distroprefs specify ".
9115                                     "an interactive test\n");
9116         }
9117         $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
9118     } elsif ( $self->_should_report('test') ) {
9119         $tests_ok = CPAN::Reporter::test($self, $system);
9120     } else {
9121         $tests_ok = system($system) == 0;
9122     }
9123     $self->introduce_myself;
9124     if ( $tests_ok ) {
9125         {
9126             my @prereq;
9127
9128             # local $CPAN::DEBUG = 16; # Distribution
9129             for my $m (keys %{$self->{sponsored_mods}}) {
9130                 next unless $self->{sponsored_mods}{$m} > 0;
9131                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
9132                 # XXX we need available_version which reflects
9133                 # $ENV{PERL5LIB} so that already tested but not yet
9134                 # installed modules are counted.
9135                 my $available_version = $m_obj->available_version;
9136                 my $available_file = $m_obj->available_file;
9137                 if ($available_version &&
9138                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
9139                    ) {
9140                     CPAN->debug("m[$m] good enough available_version[$available_version]")
9141                         if $CPAN::DEBUG;
9142                 } elsif ($available_file
9143                          && (
9144                              !$self->{prereq_pm}{$m}
9145                              ||
9146                              $self->{prereq_pm}{$m} == 0
9147                             )
9148                         ) {
9149                     # lex Class::Accessor::Chained::Fast which has no $VERSION
9150                     CPAN->debug("m[$m] have available_file[$available_file]")
9151                         if $CPAN::DEBUG;
9152                 } else {
9153                     push @prereq, $m;
9154                 }
9155             }
9156             if (@prereq) {
9157                 my $cnt = @prereq;
9158                 my $which = join ",", @prereq;
9159                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
9160                     "$cnt dependencies missing ($which)";
9161                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
9162                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
9163                 $self->store_persistent_state;
9164                 return $self->goodbye("[dependencies] -- NA");
9165             }
9166         }
9167
9168         $CPAN::Frontend->myprint("  $system -- OK\n");
9169         $self->{make_test} = CPAN::Distrostatus->new("YES");
9170         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9171         # probably impossible to need the next line because badtestcnt
9172         # has a lifespan of one command
9173         delete $self->{badtestcnt};
9174     } else {
9175         $self->{make_test} = CPAN::Distrostatus->new("NO");
9176         $self->{badtestcnt}++;
9177         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
9178         CPAN::Shell->optprint
9179               ("hint",
9180                sprintf
9181                ("//hint// to see the cpan-testers results for installing this module, try:
9182   reports %s\n",
9183                 $self->pretty_id));
9184     }
9185     $self->store_persistent_state;
9186 }
9187
9188 sub _prefs_with_expect {
9189     my($self,$where) = @_;
9190     return unless my $prefs = $self->prefs;
9191     return unless my $where_prefs = $prefs->{$where};
9192     if ($where_prefs->{expect}) {
9193         return {
9194                 mode => "deterministic",
9195                 timeout => 15,
9196                 talk => $where_prefs->{expect},
9197                };
9198     } elsif ($where_prefs->{"eexpect"}) {
9199         return $where_prefs->{"eexpect"};
9200     }
9201     return;
9202 }
9203
9204 #-> sub CPAN::Distribution::clean ;
9205 sub clean {
9206     my($self) = @_;
9207     my $make = $self->{modulebuild} ? "Build" : "make";
9208     $CPAN::Frontend->myprint("Running $make clean\n");
9209     unless (exists $self->{archived}) {
9210         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
9211                                 "/untarred, nothing done\n");
9212         return 1;
9213     }
9214     unless (exists $self->{build_dir}) {
9215         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
9216         return 1;
9217     }
9218     if (exists $self->{writemakefile}
9219         and $self->{writemakefile}->failed
9220        ) {
9221         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
9222         return 1;
9223     }
9224   EXCUSE: {
9225         my @e;
9226         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
9227             push @e, "make clean already called once";
9228         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
9229     }
9230     chdir $self->{build_dir} or
9231         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
9232     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
9233
9234     if ($^O eq 'MacOS') {
9235         Mac::BuildTools::make_clean($self);
9236         return;
9237     }
9238
9239     my $system;
9240     if ($self->{modulebuild}) {
9241         unless (-f "Build") {
9242             my $cwd = CPAN::anycwd();
9243             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
9244                                     " in cwd[$cwd]. Danger, Will Robinson!");
9245             $CPAN::Frontend->mysleep(5);
9246         }
9247         $system = sprintf "%s clean", $self->_build_command();
9248     } else {
9249         $system  = join " ", $self->_make_command(), "clean";
9250     }
9251     my $system_ok = system($system) == 0;
9252     $self->introduce_myself;
9253     if ( $system_ok ) {
9254       $CPAN::Frontend->myprint("  $system -- OK\n");
9255
9256       # $self->force;
9257
9258       # Jost Krieger pointed out that this "force" was wrong because
9259       # it has the effect that the next "install" on this distribution
9260       # will untar everything again. Instead we should bring the
9261       # object's state back to where it is after untarring.
9262
9263       for my $k (qw(
9264                     force_update
9265                     install
9266                     writemakefile
9267                     make
9268                     make_test
9269                    )) {
9270           delete $self->{$k};
9271       }
9272       $self->{make_clean} = CPAN::Distrostatus->new("YES");
9273
9274     } else {
9275       # Hmmm, what to do if make clean failed?
9276
9277       $self->{make_clean} = CPAN::Distrostatus->new("NO");
9278       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
9279
9280       # 2006-02-27: seems silly to me to force a make now
9281       # $self->force("make"); # so that this directory won't be used again
9282
9283     }
9284     $self->store_persistent_state;
9285 }
9286
9287 #-> sub CPAN::Distribution::goto ;
9288 sub goto {
9289     my($self,$goto) = @_;
9290     $goto = $self->normalize($goto);
9291     my $why = sprintf(
9292                       "Goto '$goto' via prefs file '%s' doc %d",
9293                       $self->{prefs_file},
9294                       $self->{prefs_file_doc},
9295                      );
9296     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
9297     # 2007-07-16 akoenig : Better than NA would be if we could inherit
9298     # the status of the $goto distro but given the exceptional nature
9299     # of 'goto' I feel reluctant to implement it
9300     my $goodbye_message = "[goto] -- NA $why";
9301     $self->goodbye($goodbye_message);
9302
9303     # inject into the queue
9304
9305     CPAN::Queue->delete($self->id);
9306     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
9307
9308     # and run where we left off
9309
9310     my($method) = (caller(1))[3];
9311     CPAN->instance("CPAN::Distribution",$goto)->$method();
9312     CPAN::Queue->delete_first($goto);
9313 }
9314
9315 #-> sub CPAN::Distribution::install ;
9316 sub install {
9317     my($self) = @_;
9318     if (my $goto = $self->prefs->{goto}) {
9319         return $self->goto($goto);
9320     }
9321     unless ($self->{badtestcnt}) {
9322         $self->test;
9323     }
9324     if ($CPAN::Signal) {
9325       delete $self->{force_update};
9326       return;
9327     }
9328     my $make = $self->{modulebuild} ? "Build" : "make";
9329     $CPAN::Frontend->myprint("Running $make install\n");
9330   EXCUSE: {
9331         my @e;
9332         if ($self->{make} or $self->{later}) {
9333             # go ahead
9334         } else {
9335             push @e,
9336                 "Make had some problems, won't install";
9337         }
9338
9339         exists $self->{make} and
9340             (
9341              UNIVERSAL::can($self->{make},"failed") ?
9342              $self->{make}->failed :
9343              $self->{make} =~ /^NO/
9344             ) and
9345             push @e, "Make had returned bad status, install seems impossible";
9346
9347         if (exists $self->{build_dir}) {
9348         } elsif (!@e) {
9349             push @e, "Has no own directory";
9350         }
9351
9352         if (exists $self->{make_test} and
9353             (
9354              UNIVERSAL::can($self->{make_test},"failed") ?
9355              $self->{make_test}->failed :
9356              $self->{make_test} =~ /^NO/
9357             )) {
9358             if ($self->{force_update}) {
9359                 $self->{make_test}->text("FAILED but failure ignored because ".
9360                                          "'force' in effect");
9361             } else {
9362                 push @e, "make test had returned bad status, ".
9363                     "won't install without force"
9364             }
9365         }
9366         if (exists $self->{install}) {
9367             if (UNIVERSAL::can($self->{install},"text") ?
9368                 $self->{install}->text eq "YES" :
9369                 $self->{install} =~ /^YES/
9370                ) {
9371                 $CPAN::Frontend->myprint("  Already done\n");
9372                 $CPAN::META->is_installed($self->{build_dir});
9373                 return 1;
9374             } else {
9375                 # comment in Todo on 2006-02-11; maybe retry?
9376                 push @e, "Already tried without success";
9377             }
9378         }
9379
9380         push @e, $self->{later} if $self->{later};
9381         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
9382
9383         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
9384         unless (chdir $self->{build_dir}) {
9385             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
9386         }
9387         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
9388     }
9389     $self->debug("Changed directory to $self->{build_dir}")
9390         if $CPAN::DEBUG;
9391
9392     if ($^O eq 'MacOS') {
9393         Mac::BuildTools::make_install($self);
9394         return;
9395     }
9396
9397     my $system;
9398     if (my $commandline = $self->prefs->{install}{commandline}) {
9399         $system = $commandline;
9400         $ENV{PERL} = CPAN::find_perl;
9401     } elsif ($self->{modulebuild}) {
9402         my($mbuild_install_build_command) =
9403             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
9404                 $CPAN::Config->{mbuild_install_build_command} ?
9405                     $CPAN::Config->{mbuild_install_build_command} :
9406                         $self->_build_command();
9407         $system = sprintf("%s install %s",
9408                           $mbuild_install_build_command,
9409                           $CPAN::Config->{mbuild_install_arg},
9410                          );
9411     } else {
9412         my($make_install_make_command) =
9413             CPAN::HandleConfig->prefs_lookup($self,
9414                                              q{make_install_make_command})
9415                   || $self->_make_command();
9416         $system = sprintf("%s install %s",
9417                           $make_install_make_command,
9418                           $CPAN::Config->{make_install_arg},
9419                          );
9420     }
9421
9422     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
9423     my $brip = CPAN::HandleConfig->prefs_lookup($self,
9424                                                 q{build_requires_install_policy});
9425     $brip ||="ask/yes";
9426     my $id = $self->id;
9427     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
9428     my $want_install = "yes";
9429     if ($reqtype eq "b") {
9430         if ($brip eq "no") {
9431             $want_install = "no";
9432         } elsif ($brip =~ m|^ask/(.+)|) {
9433             my $default = $1;
9434             $default = "yes" unless $default =~ /^(y|n)/i;
9435             $want_install =
9436                 CPAN::Shell::colorable_makemaker_prompt
9437                       ("$id is just needed temporarily during building or testing. ".
9438                        "Do you want to install it permanently? (Y/n)",
9439                        $default);
9440         }
9441     }
9442     unless ($want_install =~ /^y/i) {
9443         my $is_only = "is only 'build_requires'";
9444         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
9445         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
9446         delete $self->{force_update};
9447         return;
9448     }
9449     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
9450                            ? $ENV{PERL5LIB}
9451                            : ($ENV{PERLLIB} || "");
9452
9453     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
9454     $CPAN::META->set_perl5lib;
9455     my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
9456 ("Can't execute $system: $!");
9457     my($makeout) = "";
9458     while (<$pipe>) {
9459         print $_; # intentionally NOT use Frontend->myprint because it
9460                   # looks irritating when we markup in color what we
9461                   # just pass through from an external program
9462         $makeout .= $_;
9463     }
9464     $pipe->close;
9465     my $close_ok = $? == 0;
9466     $self->introduce_myself;
9467     if ( $close_ok ) {
9468         $CPAN::Frontend->myprint("  $system -- OK\n");
9469         $CPAN::META->is_installed($self->{build_dir});
9470         $self->{install} = CPAN::Distrostatus->new("YES");
9471     } else {
9472         $self->{install} = CPAN::Distrostatus->new("NO");
9473         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
9474         my $mimc =
9475             CPAN::HandleConfig->prefs_lookup($self,
9476                                              q{make_install_make_command});
9477         if (
9478             $makeout =~ /permission/s
9479             && $> > 0
9480             && (
9481                 ! $mimc
9482                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9483                                                               q{make}))
9484                )
9485            ) {
9486             $CPAN::Frontend->myprint(
9487                                      qq{----\n}.
9488                                      qq{  You may have to su }.
9489                                      qq{to root to install the package\n}.
9490                                      qq{  (Or you may want to run something like\n}.
9491                                      qq{    o conf make_install_make_command 'sudo make'\n}.
9492                                      qq{  to raise your permissions.}
9493                                     );
9494         }
9495     }
9496     delete $self->{force_update};
9497     $self->store_persistent_state;
9498 }
9499
9500 sub introduce_myself {
9501     my($self) = @_;
9502     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
9503 }
9504
9505 #-> sub CPAN::Distribution::dir ;
9506 sub dir {
9507     shift->{build_dir};
9508 }
9509
9510 #-> sub CPAN::Distribution::perldoc ;
9511 sub perldoc {
9512     my($self) = @_;
9513
9514     my($dist) = $self->id;
9515     my $package = $self->called_for;
9516
9517     $self->_display_url( $CPAN::Defaultdocs . $package );
9518 }
9519
9520 #-> sub CPAN::Distribution::_check_binary ;
9521 sub _check_binary {
9522     my ($dist,$shell,$binary) = @_;
9523     my ($pid,$out);
9524
9525     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9526       if $CPAN::DEBUG;
9527
9528     if ($CPAN::META->has_inst("File::Which")) {
9529         return File::Which::which($binary);
9530     } else {
9531         local *README;
9532         $pid = open README, "which $binary|"
9533             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9534         return unless $pid;
9535         while (<README>) {
9536             $out .= $_;
9537         }
9538         close README
9539             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9540                 and return;
9541     }
9542
9543     $CPAN::Frontend->myprint(qq{   + $out \n})
9544       if $CPAN::DEBUG && $out;
9545
9546     return $out;
9547 }
9548
9549 #-> sub CPAN::Distribution::_display_url ;
9550 sub _display_url {
9551     my($self,$url) = @_;
9552     my($res,$saved_file,$pid,$out);
9553
9554     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9555       if $CPAN::DEBUG;
9556
9557     # should we define it in the config instead?
9558     my $html_converter = "html2text.pl";
9559
9560     my $web_browser = $CPAN::Config->{'lynx'} || undef;
9561     my $web_browser_out = $web_browser
9562         ? CPAN::Distribution->_check_binary($self,$web_browser)
9563         : undef;
9564
9565     if ($web_browser_out) {
9566         # web browser found, run the action
9567         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9568         $CPAN::Frontend->myprint(qq{system[$browser $url]})
9569             if $CPAN::DEBUG;
9570         $CPAN::Frontend->myprint(qq{
9571 Displaying URL
9572   $url
9573 with browser $browser
9574 });
9575         $CPAN::Frontend->mysleep(1);
9576         system("$browser $url");
9577         if ($saved_file) { 1 while unlink($saved_file) }
9578     } else {
9579         # web browser not found, let's try text only
9580         my $html_converter_out =
9581             CPAN::Distribution->_check_binary($self,$html_converter);
9582         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9583
9584         if ($html_converter_out ) {
9585             # html2text found, run it
9586             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9587             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9588                 unless defined($saved_file);
9589
9590             local *README;
9591             $pid = open README, "$html_converter $saved_file |"
9592                 or $CPAN::Frontend->mydie(qq{
9593 Could not fork '$html_converter $saved_file': $!});
9594             my($fh,$filename);
9595             if ($CPAN::META->has_usable("File::Temp")) {
9596                 $fh = File::Temp->new(
9597                                       dir      => File::Spec->tmpdir,
9598                                       template => 'cpan_htmlconvert_XXXX',
9599                                       suffix => '.txt',
9600                                       unlink => 0,
9601                                      );
9602                 $filename = $fh->filename;
9603             } else {
9604                 $filename = "cpan_htmlconvert_$$.txt";
9605                 $fh = FileHandle->new();
9606                 open $fh, ">$filename" or die;
9607             }
9608             while (<README>) {
9609                 $fh->print($_);
9610             }
9611             close README or
9612                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9613             my $tmpin = $fh->filename;
9614             $CPAN::Frontend->myprint(sprintf(qq{
9615 Run '%s %s' and
9616 saved output to %s\n},
9617                                              $html_converter,
9618                                              $saved_file,
9619                                              $tmpin,
9620                                             )) if $CPAN::DEBUG;
9621             close $fh;
9622             local *FH;
9623             open FH, $tmpin
9624                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9625             my $fh_pager = FileHandle->new;
9626             local($SIG{PIPE}) = "IGNORE";
9627             my $pager = $CPAN::Config->{'pager'} || "cat";
9628             $fh_pager->open("|$pager")
9629                 or $CPAN::Frontend->mydie(qq{
9630 Could not open pager '$pager': $!});
9631             $CPAN::Frontend->myprint(qq{
9632 Displaying URL
9633   $url
9634 with pager "$pager"
9635 });
9636             $CPAN::Frontend->mysleep(1);
9637             $fh_pager->print(<FH>);
9638             $fh_pager->close;
9639         } else {
9640             # coldn't find the web browser or html converter
9641             $CPAN::Frontend->myprint(qq{
9642 You need to install lynx or $html_converter to use this feature.});
9643         }
9644     }
9645 }
9646
9647 #-> sub CPAN::Distribution::_getsave_url ;
9648 sub _getsave_url {
9649     my($dist, $shell, $url) = @_;
9650
9651     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9652       if $CPAN::DEBUG;
9653
9654     my($fh,$filename);
9655     if ($CPAN::META->has_usable("File::Temp")) {
9656         $fh = File::Temp->new(
9657                               dir      => File::Spec->tmpdir,
9658                               template => "cpan_getsave_url_XXXX",
9659                               suffix => ".html",
9660                               unlink => 0,
9661                              );
9662         $filename = $fh->filename;
9663     } else {
9664         $fh = FileHandle->new;
9665         $filename = "cpan_getsave_url_$$.html";
9666     }
9667     my $tmpin = $filename;
9668     if ($CPAN::META->has_usable('LWP')) {
9669         $CPAN::Frontend->myprint("Fetching with LWP:
9670   $url
9671 ");
9672         my $Ua;
9673         CPAN::LWP::UserAgent->config;
9674         eval { $Ua = CPAN::LWP::UserAgent->new; };
9675         if ($@) {
9676             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9677             return;
9678         } else {
9679             my($var);
9680             $Ua->proxy('http', $var)
9681                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9682             $Ua->no_proxy($var)
9683                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9684         }
9685
9686         my $req = HTTP::Request->new(GET => $url);
9687         $req->header('Accept' => 'text/html');
9688         my $res = $Ua->request($req);
9689         if ($res->is_success) {
9690             $CPAN::Frontend->myprint(" + request successful.\n")
9691                 if $CPAN::DEBUG;
9692             print $fh $res->content;
9693             close $fh;
9694             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9695                 if $CPAN::DEBUG;
9696             return $tmpin;
9697         } else {
9698             $CPAN::Frontend->myprint(sprintf(
9699                                              "LWP failed with code[%s], message[%s]\n",
9700                                              $res->code,
9701                                              $res->message,
9702                                             ));
9703             return;
9704         }
9705     } else {
9706         $CPAN::Frontend->mywarn("  LWP not available\n");
9707         return;
9708     }
9709 }
9710
9711 #-> sub CPAN::Distribution::_build_command
9712 sub _build_command {
9713     my($self) = @_;
9714     if ($^O eq "MSWin32") { # special code needed at least up to
9715                             # Module::Build 0.2611 and 0.2706; a fix
9716                             # in M:B has been promised 2006-01-30
9717         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9718         return "$perl ./Build";
9719     }
9720     return "./Build";
9721 }
9722
9723 #-> sub CPAN::Distribution::_should_report
9724 sub _should_report {
9725     my($self, $phase) = @_;
9726     die "_should_report() requires a 'phase' argument"
9727         if ! defined $phase;
9728
9729     # configured
9730     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9731                                                        q{test_report});
9732     return unless $test_report;
9733
9734     # don't repeat if we cached a result
9735     return $self->{should_report}
9736         if exists $self->{should_report};
9737
9738     # don't report if we generated a Makefile.PL
9739     if ( $self->{had_no_makefile_pl} ) {
9740         $CPAN::Frontend->mywarn(
9741             "Will not send CPAN Testers report with generated Makefile.PL.\n"
9742         );
9743         return $self->{should_report} = 0;
9744     }
9745
9746     # available
9747     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9748         $CPAN::Frontend->mywarn(
9749             "CPAN::Reporter not installed.  No reports will be sent.\n"
9750         );
9751         return $self->{should_report} = 0;
9752     }
9753
9754     # capable
9755     my $crv = CPAN::Reporter->VERSION;
9756     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9757         # don't cache $self->{should_report} -- need to check each phase
9758         if ( $phase eq 'test' ) {
9759             return 1;
9760         }
9761         else {
9762             $CPAN::Frontend->mywarn(
9763                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9764                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9765             );
9766             return;
9767         }
9768     }
9769
9770     # appropriate
9771     if ($self->is_dot_dist) {
9772         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9773                                 "for local directories\n");
9774         return $self->{should_report} = 0;
9775     }
9776     if ($self->prefs->{patches}
9777         &&
9778         @{$self->prefs->{patches}}
9779         &&
9780         $self->{patched}
9781        ) {
9782         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9783                                 "when the source has been patched\n");
9784         return $self->{should_report} = 0;
9785     }
9786
9787     # proceed and cache success
9788     return $self->{should_report} = 1;
9789 }
9790
9791 #-> sub CPAN::Distribution::reports
9792 sub reports {
9793     my($self) = @_;
9794     my $pathname = $self->id;
9795     $CPAN::Frontend->myprint("Distribution: $pathname\n");
9796
9797     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9798         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9799     }
9800     unless ($CPAN::META->has_usable("LWP")) {
9801         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9802     }
9803     unless ($CPAN::META->has_usable("File::Temp")) {
9804         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9805     }
9806
9807     my $d = CPAN::DistnameInfo->new($pathname);
9808
9809     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9810     my $version   = $d->version;   # "0.02"
9811     my $maturity  = $d->maturity;  # "released"
9812     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9813     my $cpanid    = $d->cpanid;    # "GBARR"
9814     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9815
9816     my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist;
9817
9818     CPAN::LWP::UserAgent->config;
9819     my $Ua;
9820     eval { $Ua = CPAN::LWP::UserAgent->new; };
9821     if ($@) {
9822         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9823     }
9824     $CPAN::Frontend->myprint("Fetching '$url'...");
9825     my $resp = $Ua->get($url);
9826     unless ($resp->is_success) {
9827         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9828     }
9829     $CPAN::Frontend->myprint("DONE\n\n");
9830     my $yaml = $resp->content;
9831     # was fuer ein Umweg!
9832     my $fh = File::Temp->new(
9833                              dir      => File::Spec->tmpdir,
9834                              template => 'cpan_reports_XXXX',
9835                              suffix => '.yaml',
9836                              unlink => 0,
9837                             );
9838     my $tfilename = $fh->filename;
9839     print $fh $yaml;
9840     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9841     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9842     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9843     my %other_versions;
9844     my $this_version_seen;
9845     for my $rep (@$unserialized) {
9846         my $rversion = $rep->{version};
9847         if ($rversion eq $version) {
9848             unless ($this_version_seen++) {
9849                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9850             }
9851             $CPAN::Frontend->myprint
9852                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9853                          $rep->{archname} eq $Config::Config{archname}?"*":"",
9854                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9855                          $rep->{action},
9856                          $rep->{perl},
9857                          ucfirst $rep->{osname},
9858                          $rep->{osvers},
9859                          $rep->{archname},
9860                         ));
9861         } else {
9862             $other_versions{$rep->{version}}++;
9863         }
9864     }
9865     unless ($this_version_seen) {
9866         $CPAN::Frontend->myprint("No reports found for version '$version'
9867 Reports for other versions:\n");
9868         for my $v (sort keys %other_versions) {
9869             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9870         }
9871     }
9872     $url =~ s/\.yaml/.html/;
9873     $CPAN::Frontend->myprint("See $url for details\n");
9874 }
9875
9876 package CPAN::Bundle;
9877 use strict;
9878
9879 sub look {
9880     my $self = shift;
9881     $CPAN::Frontend->myprint($self->as_string);
9882 }
9883
9884 #-> CPAN::Bundle::undelay
9885 sub undelay {
9886     my $self = shift;
9887     delete $self->{later};
9888     for my $c ( $self->contains ) {
9889         my $obj = CPAN::Shell->expandany($c) or next;
9890         $obj->undelay;
9891     }
9892 }
9893
9894 # mark as dirty/clean
9895 #-> sub CPAN::Bundle::color_cmd_tmps ;
9896 sub color_cmd_tmps {
9897     my($self) = shift;
9898     my($depth) = shift || 0;
9899     my($color) = shift || 0;
9900     my($ancestors) = shift || [];
9901     # a module needs to recurse to its cpan_file, a distribution needs
9902     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9903
9904     return if exists $self->{incommandcolor}
9905         && $color==1
9906         && $self->{incommandcolor}==$color;
9907     if ($depth>=$CPAN::MAX_RECURSION) {
9908         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9909     }
9910     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9911
9912     for my $c ( $self->contains ) {
9913         my $obj = CPAN::Shell->expandany($c) or next;
9914         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9915         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9916     }
9917     # never reached code?
9918     #if ($color==0) {
9919       #delete $self->{badtestcnt};
9920     #}
9921     $self->{incommandcolor} = $color;
9922 }
9923
9924 #-> sub CPAN::Bundle::as_string ;
9925 sub as_string {
9926     my($self) = @_;
9927     $self->contains;
9928     # following line must be "=", not "||=" because we have a moving target
9929     $self->{INST_VERSION} = $self->inst_version;
9930     return $self->SUPER::as_string;
9931 }
9932
9933 #-> sub CPAN::Bundle::contains ;
9934 sub contains {
9935     my($self) = @_;
9936     my($inst_file) = $self->inst_file || "";
9937     my($id) = $self->id;
9938     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9939     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9940         undef $inst_file;
9941     }
9942     unless ($inst_file) {
9943         # Try to get at it in the cpan directory
9944         $self->debug("no inst_file") if $CPAN::DEBUG;
9945         my $cpan_file;
9946         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9947               $cpan_file = $self->cpan_file;
9948         if ($cpan_file eq "N/A") {
9949             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9950   Maybe stale symlink? Maybe removed during session? Giving up.\n");
9951         }
9952         my $dist = $CPAN::META->instance('CPAN::Distribution',
9953                                          $self->cpan_file);
9954         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9955         $dist->get;
9956         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9957         my($todir) = $CPAN::Config->{'cpan_home'};
9958         my(@me,$from,$to,$me);
9959         @me = split /::/, $self->id;
9960         $me[-1] .= ".pm";
9961         $me = File::Spec->catfile(@me);
9962         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9963         $to = File::Spec->catfile($todir,$me);
9964         File::Path::mkpath(File::Basename::dirname($to));
9965         File::Copy::copy($from, $to)
9966               or Carp::confess("Couldn't copy $from to $to: $!");
9967         $inst_file = $to;
9968     }
9969     my @result;
9970     my $fh = FileHandle->new;
9971     local $/ = "\n";
9972     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9973     my $in_cont = 0;
9974     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9975     while (<$fh>) {
9976         $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
9977             m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
9978         next unless $in_cont;
9979         next if /^=/;
9980         s/\#.*//;
9981         next if /^\s+$/;
9982         chomp;
9983         push @result, (split " ", $_, 2)[0];
9984     }
9985     close $fh;
9986     delete $self->{STATUS};
9987     $self->{CONTAINS} = \@result;
9988     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9989     unless (@result) {
9990         $CPAN::Frontend->mywarn(qq{
9991 The bundle file "$inst_file" may be a broken
9992 bundlefile. It seems not to contain any bundle definition.
9993 Please check the file and if it is bogus, please delete it.
9994 Sorry for the inconvenience.
9995 });
9996     }
9997     @result;
9998 }
9999
10000 #-> sub CPAN::Bundle::find_bundle_file
10001 # $where is in local format, $what is in unix format
10002 sub find_bundle_file {
10003     my($self,$where,$what) = @_;
10004     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
10005 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
10006 ###    my $bu = File::Spec->catfile($where,$what);
10007 ###    return $bu if -f $bu;
10008     my $manifest = File::Spec->catfile($where,"MANIFEST");
10009     unless (-f $manifest) {
10010         require ExtUtils::Manifest;
10011         my $cwd = CPAN::anycwd();
10012         $self->safe_chdir($where);
10013         ExtUtils::Manifest::mkmanifest();
10014         $self->safe_chdir($cwd);
10015     }
10016     my $fh = FileHandle->new($manifest)
10017         or Carp::croak("Couldn't open $manifest: $!");
10018     local($/) = "\n";
10019     my $bundle_filename = $what;
10020     $bundle_filename =~ s|Bundle.*/||;
10021     my $bundle_unixpath;
10022     while (<$fh>) {
10023         next if /^\s*\#/;
10024         my($file) = /(\S+)/;
10025         if ($file =~ m|\Q$what\E$|) {
10026             $bundle_unixpath = $file;
10027             # return File::Spec->catfile($where,$bundle_unixpath); # bad
10028             last;
10029         }
10030         # retry if she managed to have no Bundle directory
10031         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
10032     }
10033     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
10034         if $bundle_unixpath;
10035     Carp::croak("Couldn't find a Bundle file in $where");
10036 }
10037
10038 # needs to work quite differently from Module::inst_file because of
10039 # cpan_home/Bundle/ directory and the possibility that we have
10040 # shadowing effect. As it makes no sense to take the first in @INC for
10041 # Bundles, we parse them all for $VERSION and take the newest.
10042
10043 #-> sub CPAN::Bundle::inst_file ;
10044 sub inst_file {
10045     my($self) = @_;
10046     my($inst_file);
10047     my(@me);
10048     @me = split /::/, $self->id;
10049     $me[-1] .= ".pm";
10050     my($incdir,$bestv);
10051     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
10052         my $parsefile = File::Spec->catfile($incdir, @me);
10053         CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
10054         next unless -f $parsefile;
10055         my $have = eval { MM->parse_version($parsefile); };
10056         if ($@) {
10057             $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10058         }
10059         if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
10060             $self->{INST_FILE} = $parsefile;
10061             $self->{INST_VERSION} = $bestv = $have;
10062         }
10063     }
10064     $self->{INST_FILE};
10065 }
10066
10067 #-> sub CPAN::Bundle::inst_version ;
10068 sub inst_version {
10069     my($self) = @_;
10070     $self->inst_file; # finds INST_VERSION as side effect
10071     $self->{INST_VERSION};
10072 }
10073
10074 #-> sub CPAN::Bundle::rematein ;
10075 sub rematein {
10076     my($self,$meth) = @_;
10077     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
10078     my($id) = $self->id;
10079     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
10080         unless $self->inst_file || $self->cpan_file;
10081     my($s,%fail);
10082     for $s ($self->contains) {
10083         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
10084             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
10085         if ($type eq 'CPAN::Distribution') {
10086             $CPAN::Frontend->mywarn(qq{
10087 The Bundle }.$self->id.qq{ contains
10088 explicitly a file '$s'.
10089 Going to $meth that.
10090 });
10091             $CPAN::Frontend->mysleep(5);
10092         }
10093         # possibly noisy action:
10094         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
10095         my $obj = $CPAN::META->instance($type,$s);
10096         $obj->{reqtype} = $self->{reqtype};
10097         $obj->$meth();
10098     }
10099 }
10100
10101 # If a bundle contains another that contains an xs_file we have here,
10102 # we just don't bother I suppose
10103 #-> sub CPAN::Bundle::xs_file
10104 sub xs_file {
10105     return 0;
10106 }
10107
10108 #-> sub CPAN::Bundle::force ;
10109 sub fforce   { shift->rematein('fforce',@_); }
10110 #-> sub CPAN::Bundle::force ;
10111 sub force   { shift->rematein('force',@_); }
10112 #-> sub CPAN::Bundle::notest ;
10113 sub notest  { shift->rematein('notest',@_); }
10114 #-> sub CPAN::Bundle::get ;
10115 sub get     { shift->rematein('get',@_); }
10116 #-> sub CPAN::Bundle::make ;
10117 sub make    { shift->rematein('make',@_); }
10118 #-> sub CPAN::Bundle::test ;
10119 sub test    {
10120     my $self = shift;
10121     # $self->{badtestcnt} ||= 0;
10122     $self->rematein('test',@_);
10123 }
10124 #-> sub CPAN::Bundle::install ;
10125 sub install {
10126   my $self = shift;
10127   $self->rematein('install',@_);
10128 }
10129 #-> sub CPAN::Bundle::clean ;
10130 sub clean   { shift->rematein('clean',@_); }
10131
10132 #-> sub CPAN::Bundle::uptodate ;
10133 sub uptodate {
10134     my($self) = @_;
10135     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
10136     my $c;
10137     foreach $c ($self->contains) {
10138         my $obj = CPAN::Shell->expandany($c);
10139         return 0 unless $obj->uptodate;
10140     }
10141     return 1;
10142 }
10143
10144 #-> sub CPAN::Bundle::readme ;
10145 sub readme  {
10146     my($self) = @_;
10147     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
10148 No File found for bundle } . $self->id . qq{\n}), return;
10149     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
10150     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
10151 }
10152
10153 package CPAN::Module;
10154 use strict;
10155
10156 # Accessors
10157 #-> sub CPAN::Module::userid
10158 sub userid {
10159     my $self = shift;
10160     my $ro = $self->ro;
10161     return unless $ro;
10162     return $ro->{userid} || $ro->{CPAN_USERID};
10163 }
10164 #-> sub CPAN::Module::description
10165 sub description {
10166     my $self = shift;
10167     my $ro = $self->ro or return "";
10168     $ro->{description}
10169 }
10170
10171 #-> sub CPAN::Module::distribution
10172 sub distribution {
10173     my($self) = @_;
10174     CPAN::Shell->expand("Distribution",$self->cpan_file);
10175 }
10176
10177 #-> sub CPAN::Module::_is_representative_module
10178 sub _is_representative_module {
10179     my($self) = @_;
10180     return $self->{_is_representative_module} if defined $self->{_is_representative_module};
10181     my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
10182     $pm =~ s|.+/||;
10183     $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
10184     $pm =~ s|-\d+\.\d+.+$||;
10185     $pm =~ s|-[\d\.]+$||;
10186     $pm =~ s/-/::/g;
10187     $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
10188     # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
10189     $self->{_is_representative_module};
10190 }
10191
10192 #-> sub CPAN::Module::undelay
10193 sub undelay {
10194     my $self = shift;
10195     delete $self->{later};
10196     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
10197         $dist->undelay;
10198     }
10199 }
10200
10201 # mark as dirty/clean
10202 #-> sub CPAN::Module::color_cmd_tmps ;
10203 sub color_cmd_tmps {
10204     my($self) = shift;
10205     my($depth) = shift || 0;
10206     my($color) = shift || 0;
10207     my($ancestors) = shift || [];
10208     # a module needs to recurse to its cpan_file
10209
10210     return if exists $self->{incommandcolor}
10211         && $color==1
10212         && $self->{incommandcolor}==$color;
10213     return if $color==0 && !$self->{incommandcolor};
10214     if ($color>=1) {
10215         if ( $self->uptodate ) {
10216             $self->{incommandcolor} = $color;
10217             return;
10218         } elsif (my $have_version = $self->available_version) {
10219             # maybe what we have is good enough
10220             if (@$ancestors) {
10221                 my $who_asked_for_me = $ancestors->[-1];
10222                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
10223                 if (0) {
10224                 } elsif ($obj->isa("CPAN::Bundle")) {
10225                     # bundles cannot specify a minimum version
10226                     return;
10227                 } elsif ($obj->isa("CPAN::Distribution")) {
10228                     if (my $prereq_pm = $obj->prereq_pm) {
10229                         for my $k (keys %$prereq_pm) {
10230                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
10231                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
10232                                     $self->{incommandcolor} = $color;
10233                                     return;
10234                                 }
10235                             }
10236                         }
10237                     }
10238                 }
10239             }
10240         }
10241     } else {
10242         $self->{incommandcolor} = $color; # set me before recursion,
10243                                           # so we can break it
10244     }
10245     if ($depth>=$CPAN::MAX_RECURSION) {
10246         die(CPAN::Exception::RecursiveDependency->new($ancestors));
10247     }
10248     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
10249
10250     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
10251         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
10252     }
10253     # unreached code?
10254     # if ($color==0) {
10255     #    delete $self->{badtestcnt};
10256     # }
10257     $self->{incommandcolor} = $color;
10258 }
10259
10260 #-> sub CPAN::Module::as_glimpse ;
10261 sub as_glimpse {
10262     my($self) = @_;
10263     my(@m);
10264     my $class = ref($self);
10265     $class =~ s/^CPAN:://;
10266     my $color_on = "";
10267     my $color_off = "";
10268     if (
10269         $CPAN::Shell::COLOR_REGISTERED
10270         &&
10271         $CPAN::META->has_inst("Term::ANSIColor")
10272         &&
10273         $self->description
10274        ) {
10275         $color_on = Term::ANSIColor::color("green");
10276         $color_off = Term::ANSIColor::color("reset");
10277     }
10278     my $uptodateness = " ";
10279     unless ($class eq "Bundle") {
10280         my $u = $self->uptodate;
10281         $uptodateness = $u ? "=" : "<" if defined $u;
10282     };
10283     my $id = do {
10284         my $d = $self->distribution;
10285         $d ? $d -> pretty_id : $self->cpan_userid;
10286     };
10287     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
10288                      $class,
10289                      $uptodateness,
10290                      $color_on,
10291                      $self->id,
10292                      $color_off,
10293                      $id,
10294                     );
10295     join "", @m;
10296 }
10297
10298 #-> sub CPAN::Module::dslip_status
10299 sub dslip_status {
10300     my($self) = @_;
10301     my($stat);
10302     # development status
10303     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
10304                                               pre-alpha alpha beta released
10305                                               mature standard,;
10306     # support level
10307     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
10308                                               developer comp.lang.perl.*
10309                                               none abandoned,;
10310     # language
10311     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
10312     # interface
10313     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
10314                                               references+ties
10315                                               object-oriented pragma
10316                                               hybrid none,;
10317     # public licence
10318     @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
10319                                               GPL LGPL
10320                                               BSD Artistic Artistic_2
10321                                               open-source
10322                                               distribution_allowed
10323                                               restricted_distribution
10324                                               no_licence,;
10325     for my $x (qw(d s l i p)) {
10326         $stat->{$x}{' '} = 'unknown';
10327         $stat->{$x}{'?'} = 'unknown';
10328     }
10329     my $ro = $self->ro;
10330     return +{} unless $ro && $ro->{statd};
10331     return {
10332             D  => $ro->{statd},
10333             S  => $ro->{stats},
10334             L  => $ro->{statl},
10335             I  => $ro->{stati},
10336             P  => $ro->{statp},
10337             DV => $stat->{D}{$ro->{statd}},
10338             SV => $stat->{S}{$ro->{stats}},
10339             LV => $stat->{L}{$ro->{statl}},
10340             IV => $stat->{I}{$ro->{stati}},
10341             PV => $stat->{P}{$ro->{statp}},
10342            };
10343 }
10344
10345 #-> sub CPAN::Module::as_string ;
10346 sub as_string {
10347     my($self) = @_;
10348     my(@m);
10349     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
10350     my $class = ref($self);
10351     $class =~ s/^CPAN:://;
10352     local($^W) = 0;
10353     push @m, $class, " id = $self->{ID}\n";
10354     my $sprintf = "    %-12s %s\n";
10355     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
10356         if $self->description;
10357     my $sprintf2 = "    %-12s %s (%s)\n";
10358     my($userid);
10359     $userid = $self->userid;
10360     if ( $userid ) {
10361         my $author;
10362         if ($author = CPAN::Shell->expand('Author',$userid)) {
10363             my $email = "";
10364             my $m; # old perls
10365             if ($m = $author->email) {
10366                 $email = " <$m>";
10367             }
10368             push @m, sprintf(
10369                              $sprintf2,
10370                              'CPAN_USERID',
10371                              $userid,
10372                              $author->fullname . $email
10373                             );
10374         }
10375     }
10376     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
10377         if $self->cpan_version;
10378     if (my $cpan_file = $self->cpan_file) {
10379         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
10380         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
10381             my $upload_date = $dist->upload_date;
10382             if ($upload_date) {
10383                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
10384             }
10385         }
10386     }
10387     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
10388     my $dslip = $self->dslip_status;
10389     push @m, sprintf(
10390                      $sprintf3,
10391                      'DSLIP_STATUS',
10392                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
10393                     ) if $dslip->{D};
10394     my $local_file = $self->inst_file;
10395     unless ($self->{MANPAGE}) {
10396         my $manpage;
10397         if ($local_file) {
10398             $manpage = $self->manpage_headline($local_file);
10399         } else {
10400             # If we have already untarred it, we should look there
10401             my $dist = $CPAN::META->instance('CPAN::Distribution',
10402                                              $self->cpan_file);
10403             # warn "dist[$dist]";
10404             # mff=manifest file; mfh=manifest handle
10405             my($mff,$mfh);
10406             if (
10407                 $dist->{build_dir}
10408                 and
10409                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
10410                 and
10411                 $mfh = FileHandle->new($mff)
10412                ) {
10413                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
10414                 my $lfre = $self->id; # local file RE
10415                 $lfre =~ s/::/./g;
10416                 $lfre .= "\\.pm\$";
10417                 my($lfl); # local file file
10418                 local $/ = "\n";
10419                 my(@mflines) = <$mfh>;
10420                 for (@mflines) {
10421                     s/^\s+//;
10422                     s/\s.*//s;
10423                 }
10424                 while (length($lfre)>5 and !$lfl) {
10425                     ($lfl) = grep /$lfre/, @mflines;
10426                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
10427                     $lfre =~ s/.+?\.//;
10428                 }
10429                 $lfl =~ s/\s.*//; # remove comments
10430                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
10431                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
10432                 # warn "lfl_abs[$lfl_abs]";
10433                 if (-f $lfl_abs) {
10434                     $manpage = $self->manpage_headline($lfl_abs);
10435                 }
10436             }
10437         }
10438         $self->{MANPAGE} = $manpage if $manpage;
10439     }
10440     my($item);
10441     for $item (qw/MANPAGE/) {
10442         push @m, sprintf($sprintf, $item, $self->{$item})
10443             if exists $self->{$item};
10444     }
10445     for $item (qw/CONTAINS/) {
10446         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
10447             if exists $self->{$item} && @{$self->{$item}};
10448     }
10449     push @m, sprintf($sprintf, 'INST_FILE',
10450                      $local_file || "(not installed)");
10451     push @m, sprintf($sprintf, 'INST_VERSION',
10452                      $self->inst_version) if $local_file;
10453     if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
10454         my $available_file = $self->available_file;
10455         if ($available_file && $available_file ne $local_file) {
10456             push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
10457             push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
10458         }
10459     }
10460     join "", @m, "\n";
10461 }
10462
10463 #-> sub CPAN::Module::manpage_headline
10464 sub manpage_headline {
10465     my($self,$local_file) = @_;
10466     my(@local_file) = $local_file;
10467     $local_file =~ s/\.pm(?!\n)\Z/.pod/;
10468     push @local_file, $local_file;
10469     my(@result,$locf);
10470     for $locf (@local_file) {
10471         next unless -f $locf;
10472         my $fh = FileHandle->new($locf)
10473             or $Carp::Frontend->mydie("Couldn't open $locf: $!");
10474         my $inpod = 0;
10475         local $/ = "\n";
10476         while (<$fh>) {
10477             $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
10478                 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
10479             next unless $inpod;
10480             next if /^=/;
10481             next if /^\s+$/;
10482             chomp;
10483             push @result, $_;
10484         }
10485         close $fh;
10486         last if @result;
10487     }
10488     for (@result) {
10489         s/^\s+//;
10490         s/\s+$//;
10491     }
10492     join " ", @result;
10493 }
10494
10495 #-> sub CPAN::Module::cpan_file ;
10496 # Note: also inherited by CPAN::Bundle
10497 sub cpan_file {
10498     my $self = shift;
10499     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
10500     unless ($self->ro) {
10501         CPAN::Index->reload;
10502     }
10503     my $ro = $self->ro;
10504     if ($ro && defined $ro->{CPAN_FILE}) {
10505         return $ro->{CPAN_FILE};
10506     } else {
10507         my $userid = $self->userid;
10508         if ( $userid ) {
10509             if ($CPAN::META->exists("CPAN::Author",$userid)) {
10510                 my $author = $CPAN::META->instance("CPAN::Author",
10511                                                    $userid);
10512                 my $fullname = $author->fullname;
10513                 my $email = $author->email;
10514                 unless (defined $fullname && defined $email) {
10515                     return sprintf("Contact Author %s",
10516                                    $userid,
10517                                   );
10518                 }
10519                 return "Contact Author $fullname <$email>";
10520             } else {
10521                 return "Contact Author $userid (Email address not available)";
10522             }
10523         } else {
10524             return "N/A";
10525         }
10526     }
10527 }
10528
10529 #-> sub CPAN::Module::cpan_version ;
10530 sub cpan_version {
10531     my $self = shift;
10532
10533     my $ro = $self->ro;
10534     unless ($ro) {
10535         # Can happen with modules that are not on CPAN
10536         $ro = {};
10537     }
10538     $ro->{CPAN_VERSION} = 'undef'
10539         unless defined $ro->{CPAN_VERSION};
10540     $ro->{CPAN_VERSION};
10541 }
10542
10543 #-> sub CPAN::Module::force ;
10544 sub force {
10545     my($self) = @_;
10546     $self->{force_update} = 1;
10547 }
10548
10549 #-> sub CPAN::Module::fforce ;
10550 sub fforce {
10551     my($self) = @_;
10552     $self->{force_update} = 2;
10553 }
10554
10555 #-> sub CPAN::Module::notest ;
10556 sub notest {
10557     my($self) = @_;
10558     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10559     $self->{notest}++;
10560 }
10561
10562 #-> sub CPAN::Module::rematein ;
10563 sub rematein {
10564     my($self,$meth) = @_;
10565     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10566                                      $meth,
10567                                      $self->id));
10568     my $cpan_file = $self->cpan_file;
10569     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10570         $CPAN::Frontend->mywarn(sprintf qq{
10571   The module %s isn\'t available on CPAN.
10572
10573   Either the module has not yet been uploaded to CPAN, or it is
10574   temporary unavailable. Please contact the author to find out
10575   more about the status. Try 'i %s'.
10576 },
10577                                 $self->id,
10578                                 $self->id,
10579                                );
10580         return;
10581     }
10582     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10583     $pack->called_for($self->id);
10584     if (exists $self->{force_update}) {
10585         if ($self->{force_update} == 2) {
10586             $pack->fforce($meth);
10587         } else {
10588             $pack->force($meth);
10589         }
10590     }
10591     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10592
10593     $pack->{reqtype} ||= "";
10594     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10595                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10596         if ($pack->{reqtype}) {
10597             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10598                 $pack->{reqtype} = $self->{reqtype};
10599                 if (
10600                     exists $pack->{install}
10601                     &&
10602                     (
10603                      UNIVERSAL::can($pack->{install},"failed") ?
10604                      $pack->{install}->failed :
10605                      $pack->{install} =~ /^NO/
10606                     )
10607                    ) {
10608                     delete $pack->{install};
10609                     $CPAN::Frontend->mywarn
10610                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10611                 }
10612             }
10613         } else {
10614             $pack->{reqtype} = $self->{reqtype};
10615         }
10616
10617     my $success = eval {
10618         $pack->$meth();
10619     };
10620     my $err = $@;
10621     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10622     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10623     delete $self->{force_update};
10624     delete $self->{notest};
10625     if ($err) {
10626         die $err;
10627     }
10628     return $success;
10629 }
10630
10631 #-> sub CPAN::Module::perldoc ;
10632 sub perldoc { shift->rematein('perldoc') }
10633 #-> sub CPAN::Module::readme ;
10634 sub readme  { shift->rematein('readme') }
10635 #-> sub CPAN::Module::look ;
10636 sub look    { shift->rematein('look') }
10637 #-> sub CPAN::Module::cvs_import ;
10638 sub cvs_import { shift->rematein('cvs_import') }
10639 #-> sub CPAN::Module::get ;
10640 sub get     { shift->rematein('get',@_) }
10641 #-> sub CPAN::Module::make ;
10642 sub make    { shift->rematein('make') }
10643 #-> sub CPAN::Module::test ;
10644 sub test   {
10645     my $self = shift;
10646     # $self->{badtestcnt} ||= 0;
10647     $self->rematein('test',@_);
10648 }
10649
10650 #-> sub CPAN::Module::uptodate ;
10651 sub uptodate {
10652     my ($self) = @_;
10653     local ($_);
10654     my $inst = $self->inst_version or return undef;
10655     my $cpan = $self->cpan_version;
10656     local ($^W) = 0;
10657     CPAN::Version->vgt($cpan,$inst) and return 0;
10658     CPAN->debug(join("",
10659                      "returning uptodate. inst_file[",
10660                      $self->inst_file,
10661                      "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10662     return 1;
10663 }
10664
10665 #-> sub CPAN::Module::install ;
10666 sub install {
10667     my($self) = @_;
10668     my($doit) = 0;
10669     if ($self->uptodate
10670         &&
10671         not exists $self->{force_update}
10672        ) {
10673         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10674                                          $self->id,
10675                                          $self->inst_version,
10676                                         ));
10677     } else {
10678         $doit = 1;
10679     }
10680     my $ro = $self->ro;
10681     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10682         $CPAN::Frontend->mywarn(qq{
10683 \n\n\n     ***WARNING***
10684      The module $self->{ID} has no active maintainer.\n\n\n
10685 });
10686         $CPAN::Frontend->mysleep(5);
10687     }
10688     return $doit ? $self->rematein('install') : 1;
10689 }
10690 #-> sub CPAN::Module::clean ;
10691 sub clean  { shift->rematein('clean') }
10692
10693 #-> sub CPAN::Module::inst_file ;
10694 sub inst_file {
10695     my($self) = @_;
10696     $self->_file_in_path([@INC]);
10697 }
10698
10699 #-> sub CPAN::Module::available_file ;
10700 sub available_file {
10701     my($self) = @_;
10702     my $sep = $Config::Config{path_sep};
10703     my $perllib = $ENV{PERL5LIB};
10704     $perllib = $ENV{PERLLIB} unless defined $perllib;
10705     my @perllib = split(/$sep/,$perllib) if defined $perllib;
10706     my @cpan_perl5inc;
10707     if ($CPAN::Perl5lib_tempfile) {
10708         my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
10709         @cpan_perl5inc = @{$yaml->[0]{inc} || []};
10710     }
10711     $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
10712 }
10713
10714 #-> sub CPAN::Module::file_in_path ;
10715 sub _file_in_path {
10716     my($self,$path) = @_;
10717     my($dir,@packpath);
10718     @packpath = split /::/, $self->{ID};
10719     $packpath[-1] .= ".pm";
10720     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10721         unshift @packpath, "Term", "ReadLine"; # historical reasons
10722     }
10723     foreach $dir (@$path) {
10724         my $pmfile = File::Spec->catfile($dir,@packpath);
10725         if (-f $pmfile) {
10726             return $pmfile;
10727         }
10728     }
10729     return;
10730 }
10731
10732 #-> sub CPAN::Module::xs_file ;
10733 sub xs_file {
10734     my($self) = @_;
10735     my($dir,@packpath);
10736     @packpath = split /::/, $self->{ID};
10737     push @packpath, $packpath[-1];
10738     $packpath[-1] .= "." . $Config::Config{'dlext'};
10739     foreach $dir (@INC) {
10740         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10741         if (-f $xsfile) {
10742             return $xsfile;
10743         }
10744     }
10745     return;
10746 }
10747
10748 #-> sub CPAN::Module::inst_version ;
10749 sub inst_version {
10750     my($self) = @_;
10751     my $parsefile = $self->inst_file or return;
10752     my $have = $self->parse_version($parsefile);
10753     $have;
10754 }
10755
10756 #-> sub CPAN::Module::inst_version ;
10757 sub available_version {
10758     my($self) = @_;
10759     my $parsefile = $self->available_file or return;
10760     my $have = $self->parse_version($parsefile);
10761     $have;
10762 }
10763
10764 #-> sub CPAN::Module::parse_version ;
10765 sub parse_version {
10766     my($self,$parsefile) = @_;
10767     my $have = eval { MM->parse_version($parsefile); };
10768     if ($@) {
10769         $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10770     }
10771     my $leastsanity = eval { defined $have && length $have; };
10772     $have = "undef" unless $leastsanity;
10773     $have =~ s/^ //; # since the %vd hack these two lines here are needed
10774     $have =~ s/ $//; # trailing whitespace happens all the time
10775
10776     $have = CPAN::Version->readable($have);
10777
10778     $have =~ s/\s*//g; # stringify to float around floating point issues
10779     $have; # no stringify needed, \s* above matches always
10780 }
10781
10782 #-> sub CPAN::Module::reports
10783 sub reports {
10784     my($self) = @_;
10785     $self->distribution->reports;
10786 }
10787
10788 package CPAN;
10789 use strict;
10790
10791 1;
10792
10793
10794 __END__
10795
10796 =head1 NAME
10797
10798 CPAN - query, download and build perl modules from CPAN sites
10799
10800 =head1 SYNOPSIS
10801
10802 Interactive mode:
10803
10804   perl -MCPAN -e shell
10805
10806 --or--
10807
10808   cpan
10809
10810 Basic commands:
10811
10812   # Modules:
10813
10814   cpan> install Acme::Meta                       # in the shell
10815
10816   CPAN::Shell->install("Acme::Meta");            # in perl
10817
10818   # Distributions:
10819
10820   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10821
10822   CPAN::Shell->
10823     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10824
10825   # module objects:
10826
10827   $mo = CPAN::Shell->expandany($mod);
10828   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10829
10830   # distribution objects:
10831
10832   $do = CPAN::Shell->expand("Module",$mod)->distribution;
10833   $do = CPAN::Shell->expandany($distro);         # same thing
10834   $do = CPAN::Shell->expand("Distribution",
10835                             $distro);            # same thing
10836
10837 =head1 DESCRIPTION
10838
10839 The CPAN module automates or at least simplifies the make and install
10840 of perl modules and extensions. It includes some primitive searching
10841 capabilities and knows how to use Net::FTP or LWP or some external
10842 download clients to fetch the distributions from the net.
10843
10844 These are fetched from one or more of the mirrored CPAN (Comprehensive
10845 Perl Archive Network) sites and unpacked in a dedicated directory.
10846
10847 The CPAN module also supports the concept of named and versioned
10848 I<bundles> of modules. Bundles simplify the handling of sets of
10849 related modules. See Bundles below.
10850
10851 The package contains a session manager and a cache manager. The
10852 session manager keeps track of what has been fetched, built and
10853 installed in the current session. The cache manager keeps track of the
10854 disk space occupied by the make processes and deletes excess space
10855 according to a simple FIFO mechanism.
10856
10857 All methods provided are accessible in a programmer style and in an
10858 interactive shell style.
10859
10860 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10861
10862 The interactive mode is entered by running
10863
10864     perl -MCPAN -e shell
10865
10866 or
10867
10868     cpan
10869
10870 which puts you into a readline interface. If C<Term::ReadKey> and
10871 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10872 it supports both history and command completion.
10873
10874 Once you are on the command line, type C<h> to get a one page help
10875 screen and the rest should be self-explanatory.
10876
10877 The function call C<shell> takes two optional arguments, one is the
10878 prompt, the second is the default initial command line (the latter
10879 only works if a real ReadLine interface module is installed).
10880
10881 The most common uses of the interactive modes are
10882
10883 =over 2
10884
10885 =item Searching for authors, bundles, distribution files and modules
10886
10887 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10888 for each of the four categories and another, C<i> for any of the
10889 mentioned four. Each of the four entities is implemented as a class
10890 with slightly differing methods for displaying an object.
10891
10892 Arguments you pass to these commands are either strings exactly matching
10893 the identification string of an object or regular expressions that are
10894 then matched case-insensitively against various attributes of the
10895 objects. The parser recognizes a regular expression only if you
10896 enclose it between two slashes.
10897
10898 The principle is that the number of found objects influences how an
10899 item is displayed. If the search finds one item, the result is
10900 displayed with the rather verbose method C<as_string>, but if we find
10901 more than one, we display each object with the terse method
10902 C<as_glimpse>.
10903
10904 Examples:
10905
10906   cpan> m Acme::MetaSyntactic
10907   Module id = Acme::MetaSyntactic
10908       CPAN_USERID  BOOK (Philippe Bruhat (BooK) <[...]>)
10909       CPAN_VERSION 0.99
10910       CPAN_FILE    B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10911       UPLOAD_DATE  2006-11-06
10912       MANPAGE      Acme::MetaSyntactic - Themed metasyntactic variables names
10913       INST_FILE    /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
10914       INST_VERSION 0.99
10915   cpan> a BOOK
10916   Author id = BOOK
10917       EMAIL        [...]
10918       FULLNAME     Philippe Bruhat (BooK)
10919   cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
10920   Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10921       CPAN_USERID  BOOK (Philippe Bruhat (BooK) <[...]>)
10922       CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
10923       UPLOAD_DATE  2006-11-06
10924   cpan> m /lorem/
10925   Module  = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
10926   Module    Text::Lorem            (ADEOLA/Text-Lorem-0.3.tar.gz)
10927   Module    Text::Lorem::More      (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10928   Module    Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10929   cpan> i /berlin/
10930   Distribution    BEATNIK/Filter-NumberLines-0.02.tar.gz
10931   Module  = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
10932   Module    Filter::NumberLines    (BEATNIK/Filter-NumberLines-0.02.tar.gz)
10933   Author          [...]
10934
10935 The examples illustrate several aspects: the first three queries
10936 target modules, authors, or distros directly and yield exactly one
10937 result. The last two use regular expressions and yield several
10938 results. The last one targets all of bundles, modules, authors, and
10939 distros simultaneously. When more than one result is available, they
10940 are printed in one-line format.
10941
10942 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10943
10944 These commands take any number of arguments and investigate what is
10945 necessary to perform the action. If the argument is a distribution
10946 file name (recognized by embedded slashes), it is processed. If it is
10947 a module, CPAN determines the distribution file in which this module
10948 is included and processes that, following any dependencies named in
10949 the module's META.yml or Makefile.PL (this behavior is controlled by
10950 the configuration parameter C<prerequisites_policy>.)
10951
10952 C<get> downloads a distribution file and untars or unzips it, C<make>
10953 builds it, C<test> runs the test suite, and C<install> installs it.
10954
10955 Any C<make> or C<test> are run unconditionally. An
10956
10957   install <distribution_file>
10958
10959 also is run unconditionally. But for
10960
10961   install <module>
10962
10963 CPAN checks if an install is actually needed for it and prints
10964 I<module up to date> in the case that the distribution file containing
10965 the module doesn't need to be updated.
10966
10967 CPAN also keeps track of what it has done within the current session
10968 and doesn't try to build a package a second time regardless if it
10969 succeeded or not. It does not repeat a test run if the test
10970 has been run successfully before. Same for install runs.
10971
10972 The C<force> pragma may precede another command (currently: C<get>,
10973 C<make>, C<test>, or C<install>) and executes the command from scratch
10974 and tries to continue in case of some errors. See the section below on
10975 the C<force> and the C<fforce> pragma.
10976
10977 The C<notest> pragma may be used to skip the test part in the build
10978 process.
10979
10980 Example:
10981
10982     cpan> notest install Tk
10983
10984 A C<clean> command results in a
10985
10986   make clean
10987
10988 being executed within the distribution file's working directory.
10989
10990 =item C<readme>, C<perldoc>, C<look> module or distribution
10991
10992 C<readme> displays the README file of the associated distribution.
10993 C<Look> gets and untars (if not yet done) the distribution file,
10994 changes to the appropriate directory and opens a subshell process in
10995 that directory. C<perldoc> displays the pod documentation of the
10996 module in html or plain text format.
10997
10998 =item C<ls> author
10999
11000 =item C<ls> globbing_expression
11001
11002 The first form lists all distribution files in and below an author's
11003 CPAN directory as they are stored in the CHECKUMS files distributed on
11004 CPAN. The listing goes recursive into all subdirectories.
11005
11006 The second form allows to limit or expand the output with shell
11007 globbing as in the following examples:
11008
11009       ls JV/make*
11010       ls GSAR/*make*
11011       ls */*make*
11012
11013 The last example is very slow and outputs extra progress indicators
11014 that break the alignment of the result.
11015
11016 Note that globbing only lists directories explicitly asked for, for
11017 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
11018 regarded as a bug and may be changed in future versions.
11019
11020 =item C<failed>
11021
11022 The C<failed> command reports all distributions that failed on one of
11023 C<make>, C<test> or C<install> for some reason in the currently
11024 running shell session.
11025
11026 =item Persistence between sessions
11027
11028 If the C<YAML> or the C<YAML::Syck> module is installed a record of
11029 the internal state of all modules is written to disk after each step.
11030 The files contain a signature of the currently running perl version
11031 for later perusal.
11032
11033 If the configurations variable C<build_dir_reuse> is set to a true
11034 value, then CPAN.pm reads the collected YAML files. If the stored
11035 signature matches the currently running perl the stored state is
11036 loaded into memory such that effectively persistence between sessions
11037 is established.
11038
11039 =item The C<force> and the C<fforce> pragma
11040
11041 To speed things up in complex installation scenarios, CPAN.pm keeps
11042 track of what it has already done and refuses to do some things a
11043 second time. A C<get>, a C<make>, and an C<install> are not repeated.
11044 A C<test> is only repeated if the previous test was unsuccessful. The
11045 diagnostic message when CPAN.pm refuses to do something a second time
11046 is one of I<Has already been >C<unwrapped|made|tested successfully> or
11047 something similar. Another situation where CPAN refuses to act is an
11048 C<install> if the according C<test> was not successful.
11049
11050 In all these cases, the user can override the goatish behaviour by
11051 prepending the command with the word force, for example:
11052
11053   cpan> force get Foo
11054   cpan> force make AUTHOR/Bar-3.14.tar.gz
11055   cpan> force test Baz
11056   cpan> force install Acme::Meta
11057
11058 Each I<forced> command is executed with the according part of its
11059 memory erased.
11060
11061 The C<fforce> pragma is a variant that emulates a C<force get> which
11062 erases the entire memory followed by the action specified, effectively
11063 restarting the whole get/make/test/install procedure from scratch.
11064
11065 =item Lockfile
11066
11067 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
11068 Batch jobs can run without a lockfile and do not disturb each other.
11069
11070 The shell offers to run in I<degraded mode> when another process is
11071 holding the lockfile. This is an experimental feature that is not yet
11072 tested very well. This second shell then does not write the history
11073 file, does not use the metadata file and has a different prompt.
11074
11075 =item Signals
11076
11077 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
11078 in the cpan-shell it is intended that you can press C<^C> anytime and
11079 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
11080 to clean up and leave the shell loop. You can emulate the effect of a
11081 SIGTERM by sending two consecutive SIGINTs, which usually means by
11082 pressing C<^C> twice.
11083
11084 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
11085 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
11086 Build.PL> subprocess.
11087
11088 =back
11089
11090 =head2 CPAN::Shell
11091
11092 The commands that are available in the shell interface are methods in
11093 the package CPAN::Shell. If you enter the shell command, all your
11094 input is split by the Text::ParseWords::shellwords() routine which
11095 acts like most shells do. The first word is being interpreted as the
11096 method to be called and the rest of the words are treated as arguments
11097 to this method. Continuation lines are supported if a line ends with a
11098 literal backslash.
11099
11100 =head2 autobundle
11101
11102 C<autobundle> writes a bundle file into the
11103 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
11104 a list of all modules that are both available from CPAN and currently
11105 installed within @INC. The name of the bundle file is based on the
11106 current date and a counter.
11107
11108 =head2 hosts
11109
11110 Note: this feature is still in alpha state and may change in future
11111 versions of CPAN.pm
11112
11113 This commands provides a statistical overview over recent download
11114 activities. The data for this is collected in the YAML file
11115 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
11116 configured or YAML not installed, then no stats are provided.
11117
11118 =head2 mkmyconfig
11119
11120 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
11121 directory so that you can save your own preferences instead of the
11122 system wide ones.
11123
11124 =head2 recent ***EXPERIMENTAL COMMAND***
11125
11126 The C<recent> command downloads a list of recent uploads to CPAN and
11127 displays them I<slowly>. While the command is running $SIG{INT} is
11128 defined to mean that the loop shall be left after having displayed the
11129 current item.
11130
11131 B<Note>: This command requires XML::LibXML installed.
11132
11133 B<Note>: This whole command currently is just a hack and will
11134 probably change in future versions of CPAN.pm but the general
11135 approach will likely stay.
11136
11137 B<Note>: See also L<smoke>
11138
11139 =head2 recompile
11140
11141 recompile() is a very special command in that it takes no argument and
11142 runs the make/test/install cycle with brute force over all installed
11143 dynamically loadable extensions (aka XS modules) with 'force' in
11144 effect. The primary purpose of this command is to finish a network
11145 installation. Imagine, you have a common source tree for two different
11146 architectures. You decide to do a completely independent fresh
11147 installation. You start on one architecture with the help of a Bundle
11148 file produced earlier. CPAN installs the whole Bundle for you, but
11149 when you try to repeat the job on the second architecture, CPAN
11150 responds with a C<"Foo up to date"> message for all modules. So you
11151 invoke CPAN's recompile on the second architecture and you're done.
11152
11153 Another popular use for C<recompile> is to act as a rescue in case your
11154 perl breaks binary compatibility. If one of the modules that CPAN uses
11155 is in turn depending on binary compatibility (so you cannot run CPAN
11156 commands), then you should try the CPAN::Nox module for recovery.
11157
11158 =head2 report Bundle|Distribution|Module
11159
11160 The C<report> command temporarily turns on the C<test_report> config
11161 variable, then runs the C<force test> command with the given
11162 arguments. The C<force> pragma is used to re-run the tests and repeat
11163 every step that might have failed before.
11164
11165 =head2 smoke ***EXPERIMENTAL COMMAND***
11166
11167 B<*** WARNING: this command downloads and executes software from CPAN to
11168 your computer of completely unknown status. You should never do
11169 this with your normal account and better have a dedicated well
11170 separated and secured machine to do this. ***>
11171
11172 The C<smoke> command takes the list of recent uploads to CPAN as
11173 provided by the C<recent> command and tests them all. While the
11174 command is running $SIG{INT} is defined to mean that the current item
11175 shall be skipped.
11176
11177 B<Note>: This whole command currently is just a hack and will
11178 probably change in future versions of CPAN.pm but the general
11179 approach will likely stay.
11180
11181 B<Note>: See also L<recent>
11182
11183 =head2 upgrade [Module|/Regex/]...
11184
11185 The C<upgrade> command first runs an C<r> command with the given
11186 arguments and then installs the newest versions of all modules that
11187 were listed by that.
11188
11189 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
11190
11191 Although it may be considered internal, the class hierarchy does matter
11192 for both users and programmer. CPAN.pm deals with above mentioned four
11193 classes, and all those classes share a set of methods. A classical
11194 single polymorphism is in effect. A metaclass object registers all
11195 objects of all kinds and indexes them with a string. The strings
11196 referencing objects have a separated namespace (well, not completely
11197 separated):
11198
11199          Namespace                         Class
11200
11201    words containing a "/" (slash)      Distribution
11202     words starting with Bundle::          Bundle
11203           everything else            Module or Author
11204
11205 Modules know their associated Distribution objects. They always refer
11206 to the most recent official release. Developers may mark their releases
11207 as unstable development versions (by inserting an underbar into the
11208 module version number which will also be reflected in the distribution
11209 name when you run 'make dist'), so the really hottest and newest
11210 distribution is not always the default.  If a module Foo circulates
11211 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
11212 way to install version 1.23 by saying
11213
11214     install Foo
11215
11216 This would install the complete distribution file (say
11217 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
11218 like to install version 1.23_90, you need to know where the
11219 distribution file resides on CPAN relative to the authors/id/
11220 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
11221 so you would have to say
11222
11223     install BAR/Foo-1.23_90.tar.gz
11224
11225 The first example will be driven by an object of the class
11226 CPAN::Module, the second by an object of class CPAN::Distribution.
11227
11228 =head2 Integrating local directories
11229
11230 Note: this feature is still in alpha state and may change in future
11231 versions of CPAN.pm
11232
11233 Distribution objects are normally distributions from the CPAN, but
11234 there is a slightly degenerate case for Distribution objects, too, of
11235 projects held on the local disk. These distribution objects have the
11236 same name as the local directory and end with a dot. A dot by itself
11237 is also allowed for the current directory at the time CPAN.pm was
11238 used. All actions such as C<make>, C<test>, and C<install> are applied
11239 directly to that directory. This gives the command C<cpan .> an
11240 interesting touch: while the normal mantra of installing a CPAN module
11241 without CPAN.pm is one of
11242
11243     perl Makefile.PL                 perl Build.PL
11244            ( go and get prerequisites )
11245     make                             ./Build
11246     make test                        ./Build test
11247     make install                     ./Build install
11248
11249 the command C<cpan .> does all of this at once. It figures out which
11250 of the two mantras is appropriate, fetches and installs all
11251 prerequisites, cares for them recursively and finally finishes the
11252 installation of the module in the current directory, be it a CPAN
11253 module or not.
11254
11255 The typical usage case is for private modules or working copies of
11256 projects from remote repositories on the local disk.
11257
11258 =head2 Redirection
11259
11260 The usual shell redirection symbols C< | > and C<< > >> are recognized
11261 by the cpan shell when surrounded by whitespace. So piping into a
11262 pager and redirecting output into a file works quite similar to any
11263 shell.
11264
11265 =head1 CONFIGURATION
11266
11267 When the CPAN module is used for the first time, a configuration
11268 dialog tries to determine a couple of site specific options. The
11269 result of the dialog is stored in a hash reference C< $CPAN::Config >
11270 in a file CPAN/Config.pm.
11271
11272 The default values defined in the CPAN/Config.pm file can be
11273 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
11274 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
11275 added to the search path of the CPAN module before the use() or
11276 require() statements. The mkmyconfig command writes this file for you.
11277
11278 The C<o conf> command has various bells and whistles:
11279
11280 =over
11281
11282 =item completion support
11283
11284 If you have a ReadLine module installed, you can hit TAB at any point
11285 of the commandline and C<o conf> will offer you completion for the
11286 built-in subcommands and/or config variable names.
11287
11288 =item displaying some help: o conf help
11289
11290 Displays a short help
11291
11292 =item displaying current values: o conf [KEY]
11293
11294 Displays the current value(s) for this config variable. Without KEY
11295 displays all subcommands and config variables.
11296
11297 Example:
11298
11299   o conf shell
11300
11301 If KEY starts and ends with a slash the string in between is
11302 interpreted as a regular expression and only keys matching this regex
11303 are displayed
11304
11305 Example:
11306
11307   o conf /color/
11308
11309 =item changing of scalar values: o conf KEY VALUE
11310
11311 Sets the config variable KEY to VALUE. The empty string can be
11312 specified as usual in shells, with C<''> or C<"">
11313
11314 Example:
11315
11316   o conf wget /usr/bin/wget
11317
11318 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
11319
11320 If a config variable name ends with C<list>, it is a list. C<o conf
11321 KEY shift> removes the first element of the list, C<o conf KEY pop>
11322 removes the last element of the list. C<o conf KEYS unshift LIST>
11323 prepends a list of values to the list, C<o conf KEYS push LIST>
11324 appends a list of valued to the list.
11325
11326 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
11327 splice command.
11328
11329 Finally, any other list of arguments is taken as a new list value for
11330 the KEY variable discarding the previous value.
11331
11332 Examples:
11333
11334   o conf urllist unshift http://cpan.dev.local/CPAN
11335   o conf urllist splice 3 1
11336   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
11337
11338 =item reverting to saved: o conf defaults
11339
11340 Reverts all config variables to the state in the saved config file.
11341
11342 =item saving the config: o conf commit
11343
11344 Saves all config variables to the current config file (CPAN/Config.pm
11345 or CPAN/MyConfig.pm that was loaded at start).
11346
11347 =back
11348
11349 The configuration dialog can be started any time later again by
11350 issuing the command C< o conf init > in the CPAN shell. A subset of
11351 the configuration dialog can be run by issuing C<o conf init WORD>
11352 where WORD is any valid config variable or a regular expression.
11353
11354 =head2 Config Variables
11355
11356 Currently the following keys in the hash reference $CPAN::Config are
11357 defined:
11358
11359   applypatch         path to external prg
11360   auto_commit        commit all changes to config variables to disk
11361   build_cache        size of cache for directories to build modules
11362   build_dir          locally accessible directory to build modules
11363   build_dir_reuse    boolean if distros in build_dir are persistent
11364   build_requires_install_policy
11365                      to install or not to install when a module is
11366                      only needed for building. yes|no|ask/yes|ask/no
11367   bzip2              path to external prg
11368   cache_metadata     use serializer to cache metadata
11369   check_sigs         if signatures should be verified
11370   colorize_debug     Term::ANSIColor attributes for debugging output
11371   colorize_output    boolean if Term::ANSIColor should colorize output
11372   colorize_print     Term::ANSIColor attributes for normal output
11373   colorize_warn      Term::ANSIColor attributes for warnings
11374   commandnumber_in_prompt
11375                      boolean if you want to see current command number
11376   commands_quote     prefered character to use for quoting external
11377                      commands when running them. Defaults to double
11378                      quote on Windows, single tick everywhere else;
11379                      can be set to space to disable quoting
11380   connect_to_internet_ok
11381                      if we shall ask if opening a connection is ok before
11382                      urllist is specified
11383   cpan_home          local directory reserved for this package
11384   curl               path to external prg
11385   dontload_hash      DEPRECATED
11386   dontload_list      arrayref: modules in the list will not be
11387                      loaded by the CPAN::has_inst() routine
11388   ftp                path to external prg
11389   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
11390   ftp_proxy          proxy host for ftp requests
11391   ftpstats_period    max number of days to keep download statistics
11392   ftpstats_size      max number of items to keep in the download statistics
11393   getcwd             see below
11394   gpg                path to external prg
11395   gzip               location of external program gzip
11396   halt_on_failure    stop processing after the first failure of queued
11397                      items or dependencies
11398   histfile           file to maintain history between sessions
11399   histsize           maximum number of lines to keep in histfile
11400   http_proxy         proxy host for http requests
11401   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
11402                      after this many seconds inactivity. Set to 0 to
11403                      never break.
11404   index_expire       after this many days refetch index files
11405   inhibit_startup_message
11406                      if true, does not print the startup message
11407   keep_source_where  directory in which to keep the source (if we do)
11408   load_module_verbosity
11409                      report loading of optional modules used by CPAN.pm
11410   lynx               path to external prg
11411   make               location of external make program
11412   make_arg           arguments that should always be passed to 'make'
11413   make_install_make_command
11414                      the make command for running 'make install', for
11415                      example 'sudo make'
11416   make_install_arg   same as make_arg for 'make install'
11417   makepl_arg         arguments passed to 'perl Makefile.PL'
11418   mbuild_arg         arguments passed to './Build'
11419   mbuild_install_arg arguments passed to './Build install'
11420   mbuild_install_build_command
11421                      command to use instead of './Build' when we are
11422                      in the install stage, for example 'sudo ./Build'
11423   mbuildpl_arg       arguments passed to 'perl Build.PL'
11424   ncftp              path to external prg
11425   ncftpget           path to external prg
11426   no_proxy           don't proxy to these hosts/domains (comma separated list)
11427   pager              location of external program more (or any pager)
11428   password           your password if you CPAN server wants one
11429   patch              path to external prg
11430   perl5lib_verbosity verbosity level for PERL5LIB additions
11431   prefer_installer   legal values are MB and EUMM: if a module comes
11432                      with both a Makefile.PL and a Build.PL, use the
11433                      former (EUMM) or the latter (MB); if the module
11434                      comes with only one of the two, that one will be
11435                      used in any case
11436   prerequisites_policy
11437                      what to do if you are missing module prerequisites
11438                      ('follow' automatically, 'ask' me, or 'ignore')
11439   prefs_dir          local directory to store per-distro build options
11440   proxy_user         username for accessing an authenticating proxy
11441   proxy_pass         password for accessing an authenticating proxy
11442   randomize_urllist  add some randomness to the sequence of the urllist
11443   scan_cache         controls scanning of cache ('atstart' or 'never')
11444   shell              your favorite shell
11445   show_unparsable_versions
11446                      boolean if r command tells which modules are versionless
11447   show_upload_date   boolean if commands should try to determine upload date
11448   show_zero_versions boolean if r command tells for which modules $version==0
11449   tar                location of external program tar
11450   tar_verbosity      verbosity level for the tar command
11451   term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
11452                      (and nonsense for characters outside latin range)
11453   term_ornaments     boolean to turn ReadLine ornamenting on/off
11454   test_report        email test reports (if CPAN::Reporter is installed)
11455   trust_test_report_history
11456                      skip testing when previously tested ok (according to
11457                      CPAN::Reporter history)
11458   unzip              location of external program unzip
11459   urllist            arrayref to nearby CPAN sites (or equivalent locations)
11460   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
11461   username           your username if you CPAN server wants one
11462   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
11463   wget               path to external prg
11464   yaml_load_code     enable YAML code deserialisation via CPAN::DeferedCode
11465   yaml_module        which module to use to read/write YAML files
11466
11467 You can set and query each of these options interactively in the cpan
11468 shell with the C<o conf> or the C<o conf init> command as specified below.
11469
11470 =over 2
11471
11472 =item C<o conf E<lt>scalar optionE<gt>>
11473
11474 prints the current value of the I<scalar option>
11475
11476 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
11477
11478 Sets the value of the I<scalar option> to I<value>
11479
11480 =item C<o conf E<lt>list optionE<gt>>
11481
11482 prints the current value of the I<list option> in MakeMaker's
11483 neatvalue format.
11484
11485 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
11486
11487 shifts or pops the array in the I<list option> variable
11488
11489 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
11490
11491 works like the corresponding perl commands.
11492
11493 =item interactive editing: o conf init [MATCH|LIST]
11494
11495 Runs an interactive configuration dialog for matching variables.
11496 Without argument runs the dialog over all supported config variables.
11497 To specify a MATCH the argument must be enclosed by slashes.
11498
11499 Examples:
11500
11501   o conf init ftp_passive ftp_proxy
11502   o conf init /color/
11503
11504 Note: this method of setting config variables often provides more
11505 explanation about the functioning of a variable than the manpage.
11506
11507 =back
11508
11509 =head2 CPAN::anycwd($path): Note on config variable getcwd
11510
11511 CPAN.pm changes the current working directory often and needs to
11512 determine its own current working directory. Per default it uses
11513 Cwd::cwd but if this doesn't work on your system for some reason,
11514 alternatives can be configured according to the following table:
11515
11516 =over 4
11517
11518 =item cwd
11519
11520 Calls Cwd::cwd
11521
11522 =item getcwd
11523
11524 Calls Cwd::getcwd
11525
11526 =item fastcwd
11527
11528 Calls Cwd::fastcwd
11529
11530 =item backtickcwd
11531
11532 Calls the external command cwd.
11533
11534 =back
11535
11536 =head2 Note on the format of the urllist parameter
11537
11538 urllist parameters are URLs according to RFC 1738. We do a little
11539 guessing if your URL is not compliant, but if you have problems with
11540 C<file> URLs, please try the correct format. Either:
11541
11542     file://localhost/whatever/ftp/pub/CPAN/
11543
11544 or
11545
11546     file:///home/ftp/pub/CPAN/
11547
11548 =head2 The urllist parameter has CD-ROM support
11549
11550 The C<urllist> parameter of the configuration table contains a list of
11551 URLs that are to be used for downloading. If the list contains any
11552 C<file> URLs, CPAN always tries to get files from there first. This
11553 feature is disabled for index files. So the recommendation for the
11554 owner of a CD-ROM with CPAN contents is: include your local, possibly
11555 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
11556
11557   o conf urllist push file://localhost/CDROM/CPAN
11558
11559 CPAN.pm will then fetch the index files from one of the CPAN sites
11560 that come at the beginning of urllist. It will later check for each
11561 module if there is a local copy of the most recent version.
11562
11563 Another peculiarity of urllist is that the site that we could
11564 successfully fetch the last file from automatically gets a preference
11565 token and is tried as the first site for the next request. So if you
11566 add a new site at runtime it may happen that the previously preferred
11567 site will be tried another time. This means that if you want to disallow
11568 a site for the next transfer, it must be explicitly removed from
11569 urllist.
11570
11571 =head2 Maintaining the urllist parameter
11572
11573 If you have YAML.pm (or some other YAML module configured in
11574 C<yaml_module>) installed, CPAN.pm collects a few statistical data
11575 about recent downloads. You can view the statistics with the C<hosts>
11576 command or inspect them directly by looking into the C<FTPstats.yml>
11577 file in your C<cpan_home> directory.
11578
11579 To get some interesting statistics it is recommended to set the
11580 C<randomize_urllist> parameter that introduces some amount of
11581 randomness into the URL selection.
11582
11583 =head2 The C<requires> and C<build_requires> dependency declarations
11584
11585 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11586 a distribution are treated differently depending on the config
11587 variable C<build_requires_install_policy>. By setting
11588 C<build_requires_install_policy> to C<no> such a module is not being
11589 installed. It is only built and tested and then kept in the list of
11590 tested but uninstalled modules. As such it is available during the
11591 build of the dependent module by integrating the path to the
11592 C<blib/arch> and C<blib/lib> directories in the environment variable
11593 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11594 both modules declared as C<requires> and those declared as
11595 C<build_requires> are treated alike. By setting to C<ask/yes> or
11596 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11597
11598 =head2 Configuration for individual distributions (I<Distroprefs>)
11599
11600 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11601 still considered beta quality)
11602
11603 Distributions on the CPAN usually behave according to what we call the
11604 CPAN mantra. Or since the event of Module::Build we should talk about
11605 two mantras:
11606
11607     perl Makefile.PL     perl Build.PL
11608     make                 ./Build
11609     make test            ./Build test
11610     make install         ./Build install
11611
11612 But some modules cannot be built with this mantra. They try to get
11613 some extra data from the user via the environment, extra arguments or
11614 interactively thus disturbing the installation of large bundles like
11615 Phalanx100 or modules with many dependencies like Plagger.
11616
11617 The distroprefs system of C<CPAN.pm> addresses this problem by
11618 allowing the user to specify extra informations and recipes in YAML
11619 files to either
11620
11621 =over
11622
11623 =item
11624
11625 pass additional arguments to one of the four commands,
11626
11627 =item
11628
11629 set environment variables
11630
11631 =item
11632
11633 instantiate an Expect object that reads from the console, waits for
11634 some regular expressions and enters some answers
11635
11636 =item
11637
11638 temporarily override assorted C<CPAN.pm> configuration variables
11639
11640 =item
11641
11642 specify dependencies that the original maintainer forgot to specify
11643
11644 =item
11645
11646 disable the installation of an object altogether
11647
11648 =back
11649
11650 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11651 distribution in the C<distroprefs/> directory for examples.
11652
11653 =head2 Filenames
11654
11655 The YAML files themselves must have the C<.yml> extension, all other
11656 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11657 Storable> below). The containing directory can be specified in
11658 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11659 prefs_dir> in the CPAN shell to set and activate the distroprefs
11660 system.
11661
11662 Every YAML file may contain arbitrary documents according to the YAML
11663 specification and every single document is treated as an entity that
11664 can specify the treatment of a single distribution.
11665
11666 The names of the files can be picked freely, C<CPAN.pm> always reads
11667 all files (in alphabetical order) and takes the key C<match> (see
11668 below in I<Language Specs>) as a hashref containing match criteria
11669 that determine if the current distribution matches the YAML document
11670 or not.
11671
11672 =head2 Fallback Data::Dumper and Storable
11673
11674 If neither your configured C<yaml_module> nor YAML.pm is installed
11675 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11676 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11677 directory. These files are expected to contain one or more hashrefs.
11678 For Data::Dumper generated files, this is expected to be done with by
11679 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11680 with the command
11681
11682     ysh < somefile.yml > somefile.dd
11683
11684 For Storable files the rule is that they must be constructed such that
11685 C<Storable::retrieve(file)> returns an array reference and the array
11686 elements represent one distropref object each. The conversion from
11687 YAML would look like so:
11688
11689     perl -MYAML=LoadFile -MStorable=nstore -e '
11690         @y=LoadFile(shift);
11691         nstore(\@y, shift)' somefile.yml somefile.st
11692
11693 In bootstrapping situations it is usually sufficient to translate only
11694 a few YAML files to Data::Dumper for the crucial modules like
11695 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11696 over Data::Dumper, remember to pull out a Storable version that writes
11697 an older format than all the other Storable versions that will need to
11698 read them.
11699
11700 =head2 Blueprint
11701
11702 The following example contains all supported keywords and structures
11703 with the exception of C<eexpect> which can be used instead of
11704 C<expect>.
11705
11706   ---
11707   comment: "Demo"
11708   match:
11709     module: "Dancing::Queen"
11710     distribution: "^CHACHACHA/Dancing-"
11711     perl: "/usr/local/cariba-perl/bin/perl"
11712     perlconfig:
11713       archname: "freebsd"
11714     env:
11715       DANCING_FLOOR: "Shubiduh"
11716   disabled: 1
11717   cpanconfig:
11718     make: gmake
11719   pl:
11720     args:
11721       - "--somearg=specialcase"
11722
11723     env: {}
11724
11725     expect:
11726       - "Which is your favorite fruit"
11727       - "apple\n"
11728
11729   make:
11730     args:
11731       - all
11732       - extra-all
11733
11734     env: {}
11735
11736     expect: []
11737
11738     commendline: "echo SKIPPING make"
11739
11740   test:
11741     args: []
11742
11743     env: {}
11744
11745     expect: []
11746
11747   install:
11748     args: []
11749
11750     env:
11751       WANT_TO_INSTALL: YES
11752
11753     expect:
11754       - "Do you really want to install"
11755       - "y\n"
11756
11757   patches:
11758     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11759
11760   depends:
11761     configure_requires:
11762       LWP: 5.8
11763     build_requires:
11764       Test::Exception: 0.25
11765     requires:
11766       Spiffy: 0.30
11767
11768
11769 =head2 Language Specs
11770
11771 Every YAML document represents a single hash reference. The valid keys
11772 in this hash are as follows:
11773
11774 =over
11775
11776 =item comment [scalar]
11777
11778 A comment
11779
11780 =item cpanconfig [hash]
11781
11782 Temporarily override assorted C<CPAN.pm> configuration variables.
11783
11784 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11785 C<make>, C<make_install_make_command>, C<prefer_installer>,
11786 C<test_report>. Please report as a bug when you need another one
11787 supported.
11788
11789 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11790
11791 All three types, namely C<configure_requires>, C<build_requires>, and
11792 C<requires> are supported in the way specified in the META.yml
11793 specification. The current implementation I<merges> the specified
11794 dependencies with those declared by the package maintainer. In a
11795 future implementation this may be changed to override the original
11796 declaration.
11797
11798 =item disabled [boolean]
11799
11800 Specifies that this distribution shall not be processed at all.
11801
11802 =item features [array] *** EXPERIMENTAL FEATURE ***
11803
11804 Experimental implementation to deal with optional_features from
11805 META.yml. Still needs coordination with installer software and
11806 currently only works for META.yml declaring C<dynamic_config=0>. Use
11807 with caution.
11808
11809 =item goto [string]
11810
11811 The canonical name of a delegate distribution that shall be installed
11812 instead. Useful when a new version, although it tests OK itself,
11813 breaks something else or a developer release or a fork is already
11814 uploaded that is better than the last released version.
11815
11816 =item install [hash]
11817
11818 Processing instructions for the C<make install> or C<./Build install>
11819 phase of the CPAN mantra. See below under I<Processing Instructions>.
11820
11821 =item make [hash]
11822
11823 Processing instructions for the C<make> or C<./Build> phase of the
11824 CPAN mantra. See below under I<Processing Instructions>.
11825
11826 =item match [hash]
11827
11828 A hashref with one or more of the keys C<distribution>, C<modules>,
11829 C<perl>, C<perlconfig>, and C<env> that specify if a document is
11830 targeted at a specific CPAN distribution or installation.
11831
11832 The corresponding values are interpreted as regular expressions. The
11833 C<distribution> related one will be matched against the canonical
11834 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11835
11836 The C<module> related one will be matched against I<all> modules
11837 contained in the distribution until one module matches.
11838
11839 The C<perl> related one will be matched against C<$^X> (but with the
11840 absolute path).
11841
11842 The value associated with C<perlconfig> is itself a hashref that is
11843 matched against corresponding values in the C<%Config::Config> hash
11844 living in the C<Config.pm> module.
11845
11846 The value associated with C<env> is itself a hashref that is
11847 matched against corresponding values in the C<%ENV> hash.
11848
11849 If more than one restriction of C<module>, C<distribution>, etc. is
11850 specified, the results of the separately computed match values must
11851 all match. If this is the case then the hashref represented by the
11852 YAML document is returned as the preference structure for the current
11853 distribution.
11854
11855 =item patches [array]
11856
11857 An array of patches on CPAN or on the local disk to be applied in
11858 order via the external patch program. If the value for the C<-p>
11859 parameter is C<0> or C<1> is determined by reading the patch
11860 beforehand.
11861
11862 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11863 knows about it B<and> a patch is written by the C<makepatch> program,
11864 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11865 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11866 distribution.
11867
11868 =item pl [hash]
11869
11870 Processing instructions for the C<perl Makefile.PL> or C<perl
11871 Build.PL> phase of the CPAN mantra. See below under I<Processing
11872 Instructions>.
11873
11874 =item test [hash]
11875
11876 Processing instructions for the C<make test> or C<./Build test> phase
11877 of the CPAN mantra. See below under I<Processing Instructions>.
11878
11879 =back
11880
11881 =head2 Processing Instructions
11882
11883 =over
11884
11885 =item args [array]
11886
11887 Arguments to be added to the command line
11888
11889 =item commandline
11890
11891 A full commandline that will be executed as it stands by a system
11892 call. During the execution the environment variable PERL will is set
11893 to $^X (but with an absolute path). If C<commandline> is specified,
11894 the content of C<args> is not used.
11895
11896 =item eexpect [hash]
11897
11898 Extended C<expect>. This is a hash reference with four allowed keys,
11899 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11900
11901 C<mode> may have the values C<deterministic> for the case where all
11902 questions come in the order written down and C<anyorder> for the case
11903 where the questions may come in any order. The default mode is
11904 C<deterministic>.
11905
11906 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11907 OK. In the case of a C<mode=deterministic> the timeout denotes the
11908 timeout per question, in the case of C<mode=anyorder> it denotes the
11909 timeout per byte received from the stream or questions.
11910
11911 C<talk> is a reference to an array that contains alternating questions
11912 and answers. Questions are regular expressions and answers are literal
11913 strings. The Expect module will then watch the stream coming from the
11914 execution of the external program (C<perl Makefile.PL>, C<perl
11915 Build.PL>, C<make>, etc.).
11916
11917 In the case of C<mode=deterministic> the CPAN.pm will inject the
11918 according answer as soon as the stream matches the regular expression.
11919
11920 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11921 as the timeout is reached for the next byte in the input stream. In
11922 this mode you can use the C<reuse> parameter to decide what shall
11923 happen with a question-answer pair after it has been used. In the
11924 default case (reuse=0) it is removed from the array, so it cannot be
11925 used again accidentally. In this case, if you want to answer the
11926 question C<Do you really want to do that> several times, then it must
11927 be included in the array at least as often as you want this answer to
11928 be given. Setting the parameter C<reuse> to 1 makes this repetition
11929 unnecessary.
11930
11931 =item env [hash]
11932
11933 Environment variables to be set during the command
11934
11935 =item expect [array]
11936
11937 C<< expect: <array> >> is a short notation for
11938
11939   eexpect:
11940     mode: deterministic
11941     timeout: 15
11942     talk: <array>
11943
11944 =back
11945
11946 =head2 Schema verification with C<Kwalify>
11947
11948 If you have the C<Kwalify> module installed (which is part of the
11949 Bundle::CPANxxl), then all your distroprefs files are checked for
11950 syntactical correctness.
11951
11952 =head2 Example Distroprefs Files
11953
11954 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11955 are really just examples and should not be used without care because
11956 they cannot fit everybody's purpose. After all the authors of the
11957 packages that ask questions had a need to ask, so you should watch
11958 their questions and adjust the examples to your environment and your
11959 needs. You have beend warned:-)
11960
11961 =head1 PROGRAMMER'S INTERFACE
11962
11963 If you do not enter the shell, the available shell commands are both
11964 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11965 functions in the calling package (C<install(...)>).  Before calling low-level
11966 commands it makes sense to initialize components of CPAN you need, e.g.:
11967
11968   CPAN::HandleConfig->load;
11969   CPAN::Shell::setup_output;
11970   CPAN::Index->reload;
11971
11972 High-level commands do such initializations automatically.
11973
11974 There's currently only one class that has a stable interface -
11975 CPAN::Shell. All commands that are available in the CPAN shell are
11976 methods of the class CPAN::Shell. Each of the commands that produce
11977 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11978 the IDs of all modules within the list.
11979
11980 =over 2
11981
11982 =item expand($type,@things)
11983
11984 The IDs of all objects available within a program are strings that can
11985 be expanded to the corresponding real objects with the
11986 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11987 list of CPAN::Module objects according to the C<@things> arguments
11988 given. In scalar context it only returns the first element of the
11989 list.
11990
11991 =item expandany(@things)
11992
11993 Like expand, but returns objects of the appropriate type, i.e.
11994 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11995 CPAN::Distribution objects for distributions. Note: it does not expand
11996 to CPAN::Author objects.
11997
11998 =item Programming Examples
11999
12000 This enables the programmer to do operations that combine
12001 functionalities that are available in the shell.
12002
12003     # install everything that is outdated on my disk:
12004     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
12005
12006     # install my favorite programs if necessary:
12007     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
12008         CPAN::Shell->install($mod);
12009     }
12010
12011     # list all modules on my disk that have no VERSION number
12012     for $mod (CPAN::Shell->expand("Module","/./")) {
12013         next unless $mod->inst_file;
12014         # MakeMaker convention for undefined $VERSION:
12015         next unless $mod->inst_version eq "undef";
12016         print "No VERSION in ", $mod->id, "\n";
12017     }
12018
12019     # find out which distribution on CPAN contains a module:
12020     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
12021
12022 Or if you want to write a cronjob to watch The CPAN, you could list
12023 all modules that need updating. First a quick and dirty way:
12024
12025     perl -e 'use CPAN; CPAN::Shell->r;'
12026
12027 If you don't want to get any output in the case that all modules are
12028 up to date, you can parse the output of above command for the regular
12029 expression //modules are up to date// and decide to mail the output
12030 only if it doesn't match. Ick?
12031
12032 If you prefer to do it more in a programmer style in one single
12033 process, maybe something like this suits you better:
12034
12035   # list all modules on my disk that have newer versions on CPAN
12036   for $mod (CPAN::Shell->expand("Module","/./")) {
12037     next unless $mod->inst_file;
12038     next if $mod->uptodate;
12039     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
12040         $mod->id, $mod->inst_version, $mod->cpan_version;
12041   }
12042
12043 If that gives you too much output every day, you maybe only want to
12044 watch for three modules. You can write
12045
12046   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
12047
12048 as the first line instead. Or you can combine some of the above
12049 tricks:
12050
12051   # watch only for a new mod_perl module
12052   $mod = CPAN::Shell->expand("Module","mod_perl");
12053   exit if $mod->uptodate;
12054   # new mod_perl arrived, let me know all update recommendations
12055   CPAN::Shell->r;
12056
12057 =back
12058
12059 =head2 Methods in the other Classes
12060
12061 =over 4
12062
12063 =item CPAN::Author::as_glimpse()
12064
12065 Returns a one-line description of the author
12066
12067 =item CPAN::Author::as_string()
12068
12069 Returns a multi-line description of the author
12070
12071 =item CPAN::Author::email()
12072
12073 Returns the author's email address
12074
12075 =item CPAN::Author::fullname()
12076
12077 Returns the author's name
12078
12079 =item CPAN::Author::name()
12080
12081 An alias for fullname
12082
12083 =item CPAN::Bundle::as_glimpse()
12084
12085 Returns a one-line description of the bundle
12086
12087 =item CPAN::Bundle::as_string()
12088
12089 Returns a multi-line description of the bundle
12090
12091 =item CPAN::Bundle::clean()
12092
12093 Recursively runs the C<clean> method on all items contained in the bundle.
12094
12095 =item CPAN::Bundle::contains()
12096
12097 Returns a list of objects' IDs contained in a bundle. The associated
12098 objects may be bundles, modules or distributions.
12099
12100 =item CPAN::Bundle::force($method,@args)
12101
12102 Forces CPAN to perform a task that it normally would have refused to
12103 do. Force takes as arguments a method name to be called and any number
12104 of additional arguments that should be passed to the called method.
12105 The internals of the object get the needed changes so that CPAN.pm
12106 does not refuse to take the action. The C<force> is passed recursively
12107 to all contained objects. See also the section above on the C<force>
12108 and the C<fforce> pragma.
12109
12110 =item CPAN::Bundle::get()
12111
12112 Recursively runs the C<get> method on all items contained in the bundle
12113
12114 =item CPAN::Bundle::inst_file()
12115
12116 Returns the highest installed version of the bundle in either @INC or
12117 C<$CPAN::Config->{cpan_home}>. Note that this is different from
12118 CPAN::Module::inst_file.
12119
12120 =item CPAN::Bundle::inst_version()
12121
12122 Like CPAN::Bundle::inst_file, but returns the $VERSION
12123
12124 =item CPAN::Bundle::uptodate()
12125
12126 Returns 1 if the bundle itself and all its members are uptodate.
12127
12128 =item CPAN::Bundle::install()
12129
12130 Recursively runs the C<install> method on all items contained in the bundle
12131
12132 =item CPAN::Bundle::make()
12133
12134 Recursively runs the C<make> method on all items contained in the bundle
12135
12136 =item CPAN::Bundle::readme()
12137
12138 Recursively runs the C<readme> method on all items contained in the bundle
12139
12140 =item CPAN::Bundle::test()
12141
12142 Recursively runs the C<test> method on all items contained in the bundle
12143
12144 =item CPAN::Distribution::as_glimpse()
12145
12146 Returns a one-line description of the distribution
12147
12148 =item CPAN::Distribution::as_string()
12149
12150 Returns a multi-line description of the distribution
12151
12152 =item CPAN::Distribution::author
12153
12154 Returns the CPAN::Author object of the maintainer who uploaded this
12155 distribution
12156
12157 =item CPAN::Distribution::pretty_id()
12158
12159 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
12160 author's PAUSE ID and TARBALL is the distribution filename.
12161
12162 =item CPAN::Distribution::base_id()
12163
12164 Returns the distribution filename without any archive suffix.  E.g
12165 "Foo-Bar-0.01"
12166
12167 =item CPAN::Distribution::clean()
12168
12169 Changes to the directory where the distribution has been unpacked and
12170 runs C<make clean> there.
12171
12172 =item CPAN::Distribution::containsmods()
12173
12174 Returns a list of IDs of modules contained in a distribution file.
12175 Only works for distributions listed in the 02packages.details.txt.gz
12176 file. This typically means that only the most recent version of a
12177 distribution is covered.
12178
12179 =item CPAN::Distribution::cvs_import()
12180
12181 Changes to the directory where the distribution has been unpacked and
12182 runs something like
12183
12184     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
12185
12186 there.
12187
12188 =item CPAN::Distribution::dir()
12189
12190 Returns the directory into which this distribution has been unpacked.
12191
12192 =item CPAN::Distribution::force($method,@args)
12193
12194 Forces CPAN to perform a task that it normally would have refused to
12195 do. Force takes as arguments a method name to be called and any number
12196 of additional arguments that should be passed to the called method.
12197 The internals of the object get the needed changes so that CPAN.pm
12198 does not refuse to take the action. See also the section above on the
12199 C<force> and the C<fforce> pragma.
12200
12201 =item CPAN::Distribution::get()
12202
12203 Downloads the distribution from CPAN and unpacks it. Does nothing if
12204 the distribution has already been downloaded and unpacked within the
12205 current session.
12206
12207 =item CPAN::Distribution::install()
12208
12209 Changes to the directory where the distribution has been unpacked and
12210 runs the external command C<make install> there. If C<make> has not
12211 yet been run, it will be run first. A C<make test> will be issued in
12212 any case and if this fails, the install will be canceled. The
12213 cancellation can be avoided by letting C<force> run the C<install> for
12214 you.
12215
12216 This install method has only the power to install the distribution if
12217 there are no dependencies in the way. To install an object and all of
12218 its dependencies, use CPAN::Shell->install.
12219
12220 Note that install() gives no meaningful return value. See uptodate().
12221
12222 =item CPAN::Distribution::install_tested()
12223
12224 Install all the distributions that have been tested sucessfully but
12225 not yet installed. See also C<is_tested>.
12226
12227 =item CPAN::Distribution::isa_perl()
12228
12229 Returns 1 if this distribution file seems to be a perl distribution.
12230 Normally this is derived from the file name only, but the index from
12231 CPAN can contain a hint to achieve a return value of true for other
12232 filenames too.
12233
12234 =item CPAN::Distribution::look()
12235
12236 Changes to the directory where the distribution has been unpacked and
12237 opens a subshell there. Exiting the subshell returns.
12238
12239 =item CPAN::Distribution::make()
12240
12241 First runs the C<get> method to make sure the distribution is
12242 downloaded and unpacked. Changes to the directory where the
12243 distribution has been unpacked and runs the external commands C<perl
12244 Makefile.PL> or C<perl Build.PL> and C<make> there.
12245
12246 =item CPAN::Distribution::perldoc()
12247
12248 Downloads the pod documentation of the file associated with a
12249 distribution (in html format) and runs it through the external
12250 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
12251 isn't available, it converts it to plain text with external
12252 command html2text and runs it through the pager specified
12253 in C<$CPAN::Config->{pager}>
12254
12255 =item CPAN::Distribution::prefs()
12256
12257 Returns the hash reference from the first matching YAML file that the
12258 user has deposited in the C<prefs_dir/> directory. The first
12259 succeeding match wins. The files in the C<prefs_dir/> are processed
12260 alphabetically and the canonical distroname (e.g.
12261 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
12262 stored in the $root->{match}{distribution} attribute value.
12263 Additionally all module names contained in a distribution are matched
12264 agains the regular expressions in the $root->{match}{module} attribute
12265 value. The two match values are ANDed together. Each of the two
12266 attributes are optional.
12267
12268 =item CPAN::Distribution::prereq_pm()
12269
12270 Returns the hash reference that has been announced by a distribution
12271 as the the C<requires> and C<build_requires> elements. These can be
12272 declared either by the C<META.yml> (if authoritative) or can be
12273 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
12274 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
12275 a comment in the produced C<Makefile>. I<Note>: this method only works
12276 after an attempt has been made to C<make> the distribution. Returns
12277 undef otherwise.
12278
12279 =item CPAN::Distribution::readme()
12280
12281 Downloads the README file associated with a distribution and runs it
12282 through the pager specified in C<$CPAN::Config->{pager}>.
12283
12284 =item CPAN::Distribution::reports()
12285
12286 Downloads report data for this distribution from www.cpantesters.org
12287 and displays a subset of them.
12288
12289 =item CPAN::Distribution::read_yaml()
12290
12291 Returns the content of the META.yml of this distro as a hashref. Note:
12292 works only after an attempt has been made to C<make> the distribution.
12293 Returns undef otherwise. Also returns undef if the content of META.yml
12294 is not authoritative. (The rules about what exactly makes the content
12295 authoritative are still in flux.)
12296
12297 =item CPAN::Distribution::test()
12298
12299 Changes to the directory where the distribution has been unpacked and
12300 runs C<make test> there.
12301
12302 =item CPAN::Distribution::uptodate()
12303
12304 Returns 1 if all the modules contained in the distribution are
12305 uptodate. Relies on containsmods.
12306
12307 =item CPAN::Index::force_reload()
12308
12309 Forces a reload of all indices.
12310
12311 =item CPAN::Index::reload()
12312
12313 Reloads all indices if they have not been read for more than
12314 C<$CPAN::Config->{index_expire}> days.
12315
12316 =item CPAN::InfoObj::dump()
12317
12318 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
12319 inherit this method. It prints the data structure associated with an
12320 object. Useful for debugging. Note: the data structure is considered
12321 internal and thus subject to change without notice.
12322
12323 =item CPAN::Module::as_glimpse()
12324
12325 Returns a one-line description of the module in four columns: The
12326 first column contains the word C<Module>, the second column consists
12327 of one character: an equals sign if this module is already installed
12328 and uptodate, a less-than sign if this module is installed but can be
12329 upgraded, and a space if the module is not installed. The third column
12330 is the name of the module and the fourth column gives maintainer or
12331 distribution information.
12332
12333 =item CPAN::Module::as_string()
12334
12335 Returns a multi-line description of the module
12336
12337 =item CPAN::Module::clean()
12338
12339 Runs a clean on the distribution associated with this module.
12340
12341 =item CPAN::Module::cpan_file()
12342
12343 Returns the filename on CPAN that is associated with the module.
12344
12345 =item CPAN::Module::cpan_version()
12346
12347 Returns the latest version of this module available on CPAN.
12348
12349 =item CPAN::Module::cvs_import()
12350
12351 Runs a cvs_import on the distribution associated with this module.
12352
12353 =item CPAN::Module::description()
12354
12355 Returns a 44 character description of this module. Only available for
12356 modules listed in The Module List (CPAN/modules/00modlist.long.html
12357 or 00modlist.long.txt.gz)
12358
12359 =item CPAN::Module::distribution()
12360
12361 Returns the CPAN::Distribution object that contains the current
12362 version of this module.
12363
12364 =item CPAN::Module::dslip_status()
12365
12366 Returns a hash reference. The keys of the hash are the letters C<D>,
12367 C<S>, C<L>, C<I>, and <P>, for development status, support level,
12368 language, interface and public licence respectively. The data for the
12369 DSLIP status are collected by pause.perl.org when authors register
12370 their namespaces. The values of the 5 hash elements are one-character
12371 words whose meaning is described in the table below. There are also 5
12372 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
12373 verbose value of the 5 status variables.
12374
12375 Where the 'DSLIP' characters have the following meanings:
12376
12377   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
12378     i   - Idea, listed to gain consensus or as a placeholder
12379     c   - under construction but pre-alpha (not yet released)
12380     a/b - Alpha/Beta testing
12381     R   - Released
12382     M   - Mature (no rigorous definition)
12383     S   - Standard, supplied with Perl 5
12384
12385   S - Support Level:
12386     m   - Mailing-list
12387     d   - Developer
12388     u   - Usenet newsgroup comp.lang.perl.modules
12389     n   - None known, try comp.lang.perl.modules
12390     a   - abandoned; volunteers welcome to take over maintainance
12391
12392   L - Language Used:
12393     p   - Perl-only, no compiler needed, should be platform independent
12394     c   - C and perl, a C compiler will be needed
12395     h   - Hybrid, written in perl with optional C code, no compiler needed
12396     +   - C++ and perl, a C++ compiler will be needed
12397     o   - perl and another language other than C or C++
12398
12399   I - Interface Style
12400     f   - plain Functions, no references used
12401     h   - hybrid, object and function interfaces available
12402     n   - no interface at all (huh?)
12403     r   - some use of unblessed References or ties
12404     O   - Object oriented using blessed references and/or inheritance
12405
12406   P - Public License
12407     p   - Standard-Perl: user may choose between GPL and Artistic
12408     g   - GPL: GNU General Public License
12409     l   - LGPL: "GNU Lesser General Public License" (previously known as
12410           "GNU Library General Public License")
12411     b   - BSD: The BSD License
12412     a   - Artistic license alone
12413     2   - Artistic license 2.0 or later
12414     o   - open source: appoved by www.opensource.org
12415     d   - allows distribution without restrictions
12416     r   - restricted distribtion
12417     n   - no license at all
12418
12419 =item CPAN::Module::force($method,@args)
12420
12421 Forces CPAN to perform a task that it normally would have refused to
12422 do. Force takes as arguments a method name to be called and any number
12423 of additional arguments that should be passed to the called method.
12424 The internals of the object get the needed changes so that CPAN.pm
12425 does not refuse to take the action. See also the section above on the
12426 C<force> and the C<fforce> pragma.
12427
12428 =item CPAN::Module::get()
12429
12430 Runs a get on the distribution associated with this module.
12431
12432 =item CPAN::Module::inst_file()
12433
12434 Returns the filename of the module found in @INC. The first file found
12435 is reported just like perl itself stops searching @INC when it finds a
12436 module.
12437
12438 =item CPAN::Module::available_file()
12439
12440 Returns the filename of the module found in PERL5LIB or @INC. The
12441 first file found is reported. The advantage of this method over
12442 C<inst_file> is that modules that have been tested but not yet
12443 installed are included because PERL5LIB keeps track of tested modules.
12444
12445 =item CPAN::Module::inst_version()
12446
12447 Returns the version number of the installed module in readable format.
12448
12449 =item CPAN::Module::available_version()
12450
12451 Returns the version number of the available module in readable format.
12452
12453 =item CPAN::Module::install()
12454
12455 Runs an C<install> on the distribution associated with this module.
12456
12457 =item CPAN::Module::look()
12458
12459 Changes to the directory where the distribution associated with this
12460 module has been unpacked and opens a subshell there. Exiting the
12461 subshell returns.
12462
12463 =item CPAN::Module::make()
12464
12465 Runs a C<make> on the distribution associated with this module.
12466
12467 =item CPAN::Module::manpage_headline()
12468
12469 If module is installed, peeks into the module's manpage, reads the
12470 headline and returns it. Moreover, if the module has been downloaded
12471 within this session, does the equivalent on the downloaded module even
12472 if it is not installed.
12473
12474 =item CPAN::Module::perldoc()
12475
12476 Runs a C<perldoc> on this module.
12477
12478 =item CPAN::Module::readme()
12479
12480 Runs a C<readme> on the distribution associated with this module.
12481
12482 =item CPAN::Module::reports()
12483
12484 Calls the reports() method on the associated distribution object.
12485
12486 =item CPAN::Module::test()
12487
12488 Runs a C<test> on the distribution associated with this module.
12489
12490 =item CPAN::Module::uptodate()
12491
12492 Returns 1 if the module is installed and up-to-date.
12493
12494 =item CPAN::Module::userid()
12495
12496 Returns the author's ID of the module.
12497
12498 =back
12499
12500 =head2 Cache Manager
12501
12502 Currently the cache manager only keeps track of the build directory
12503 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
12504 deletes complete directories below C<build_dir> as soon as the size of
12505 all directories there gets bigger than $CPAN::Config->{build_cache}
12506 (in MB). The contents of this cache may be used for later
12507 re-installations that you intend to do manually, but will never be
12508 trusted by CPAN itself. This is due to the fact that the user might
12509 use these directories for building modules on different architectures.
12510
12511 There is another directory ($CPAN::Config->{keep_source_where}) where
12512 the original distribution files are kept. This directory is not
12513 covered by the cache manager and must be controlled by the user. If
12514 you choose to have the same directory as build_dir and as
12515 keep_source_where directory, then your sources will be deleted with
12516 the same fifo mechanism.
12517
12518 =head2 Bundles
12519
12520 A bundle is just a perl module in the namespace Bundle:: that does not
12521 define any functions or methods. It usually only contains documentation.
12522
12523 It starts like a perl module with a package declaration and a $VERSION
12524 variable. After that the pod section looks like any other pod with the
12525 only difference being that I<one special pod section> exists starting with
12526 (verbatim):
12527
12528     =head1 CONTENTS
12529
12530 In this pod section each line obeys the format
12531
12532         Module_Name [Version_String] [- optional text]
12533
12534 The only required part is the first field, the name of a module
12535 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
12536 of the line is optional. The comment part is delimited by a dash just
12537 as in the man page header.
12538
12539 The distribution of a bundle should follow the same convention as
12540 other distributions.
12541
12542 Bundles are treated specially in the CPAN package. If you say 'install
12543 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
12544 the modules in the CONTENTS section of the pod. You can install your
12545 own Bundles locally by placing a conformant Bundle file somewhere into
12546 your @INC path. The autobundle() command which is available in the
12547 shell interface does that for you by including all currently installed
12548 modules in a snapshot bundle file.
12549
12550 =head1 PREREQUISITES
12551
12552 If you have a local mirror of CPAN and can access all files with
12553 "file:" URLs, then you only need a perl better than perl5.003 to run
12554 this module. Otherwise Net::FTP is strongly recommended. LWP may be
12555 required for non-UNIX systems or if your nearest CPAN site is
12556 associated with a URL that is not C<ftp:>.
12557
12558 If you have neither Net::FTP nor LWP, there is a fallback mechanism
12559 implemented for an external ftp command or for an external lynx
12560 command.
12561
12562 =head1 UTILITIES
12563
12564 =head2 Finding packages and VERSION
12565
12566 This module presumes that all packages on CPAN
12567
12568 =over 2
12569
12570 =item *
12571
12572 declare their $VERSION variable in an easy to parse manner. This
12573 prerequisite can hardly be relaxed because it consumes far too much
12574 memory to load all packages into the running program just to determine
12575 the $VERSION variable. Currently all programs that are dealing with
12576 version use something like this
12577
12578     perl -MExtUtils::MakeMaker -le \
12579         'print MM->parse_version(shift)' filename
12580
12581 If you are author of a package and wonder if your $VERSION can be
12582 parsed, please try the above method.
12583
12584 =item *
12585
12586 come as compressed or gzipped tarfiles or as zip files and contain a
12587 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12588 without much enthusiasm).
12589
12590 =back
12591
12592 =head2 Debugging
12593
12594 The debugging of this module is a bit complex, because we have
12595 interferences of the software producing the indices on CPAN, of the
12596 mirroring process on CPAN, of packaging, of configuration, of
12597 synchronicity, and of bugs within CPAN.pm.
12598
12599 For debugging the code of CPAN.pm itself in interactive mode some more
12600 or less useful debugging aid can be turned on for most packages within
12601 CPAN.pm with one of
12602
12603 =over 2
12604
12605 =item o debug package...
12606
12607 sets debug mode for packages.
12608
12609 =item o debug -package...
12610
12611 unsets debug mode for packages.
12612
12613 =item o debug all
12614
12615 turns debugging on for all packages.
12616
12617 =item o debug number
12618
12619 =back
12620
12621 which sets the debugging packages directly. Note that C<o debug 0>
12622 turns debugging off.
12623
12624 What seems quite a successful strategy is the combination of C<reload
12625 cpan> and the debugging switches. Add a new debug statement while
12626 running in the shell and then issue a C<reload cpan> and see the new
12627 debugging messages immediately without losing the current context.
12628
12629 C<o debug> without an argument lists the valid package names and the
12630 current set of packages in debugging mode. C<o debug> has built-in
12631 completion support.
12632
12633 For debugging of CPAN data there is the C<dump> command which takes
12634 the same arguments as make/test/install and outputs each object's
12635 Data::Dumper dump. If an argument looks like a perl variable and
12636 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12637 Data::Dumper directly.
12638
12639 =head2 Floppy, Zip, Offline Mode
12640
12641 CPAN.pm works nicely without network too. If you maintain machines
12642 that are not networked at all, you should consider working with file:
12643 URLs. Of course, you have to collect your modules somewhere first. So
12644 you might use CPAN.pm to put together all you need on a networked
12645 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12646 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12647 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12648 with this floppy. See also below the paragraph about CD-ROM support.
12649
12650 =head2 Basic Utilities for Programmers
12651
12652 =over 2
12653
12654 =item has_inst($module)
12655
12656 Returns true if the module is installed. Used to load all modules into
12657 the running CPAN.pm which are considered optional. The config variable
12658 C<dontload_list> can be used to intercept the C<has_inst()> call such
12659 that an optional module is not loaded despite being available. For
12660 example the following command will prevent that C<YAML.pm> is being
12661 loaded:
12662
12663     cpan> o conf dontload_list push YAML
12664
12665 See the source for details.
12666
12667 =item has_usable($module)
12668
12669 Returns true if the module is installed and is in a usable state. Only
12670 useful for a handful of modules that are used internally. See the
12671 source for details.
12672
12673 =item instance($module)
12674
12675 The constructor for all the singletons used to represent modules,
12676 distributions, authors and bundles. If the object already exists, this
12677 method returns the object, otherwise it calls the constructor.
12678
12679 =back
12680
12681 =head1 SECURITY
12682
12683 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12684 install foreign, unmasked, unsigned code on your machine. We compare
12685 to a checksum that comes from the net just as the distribution file
12686 itself. But we try to make it easy to add security on demand:
12687
12688 =head2 Cryptographically signed modules
12689
12690 Since release 1.77 CPAN.pm has been able to verify cryptographically
12691 signed module distributions using Module::Signature.  The CPAN modules
12692 can be signed by their authors, thus giving more security.  The simple
12693 unsigned MD5 checksums that were used before by CPAN protect mainly
12694 against accidental file corruption.
12695
12696 You will need to have Module::Signature installed, which in turn
12697 requires that you have at least one of Crypt::OpenPGP module or the
12698 command-line F<gpg> tool installed.
12699
12700 You will also need to be able to connect over the Internet to the public
12701 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12702
12703 The configuration parameter check_sigs is there to turn signature
12704 checking on or off.
12705
12706 =head1 EXPORT
12707
12708 Most functions in package CPAN are exported per default. The reason
12709 for this is that the primary use is intended for the cpan shell or for
12710 one-liners.
12711
12712 =head1 ENVIRONMENT
12713
12714 When the CPAN shell enters a subshell via the look command, it sets
12715 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12716 already set.
12717
12718 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12719 to the ID of the running process. It also sets
12720 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12721 happen with older versions of Module::Install.
12722
12723 When running C<perl Makefile.PL>, the environment variable
12724 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12725 C<Makefile.PL> that is being executed. This prevents runaway processes
12726 with newer versions of Module::Install.
12727
12728 When the config variable ftp_passive is set, all downloads will be run
12729 with the environment variable FTP_PASSIVE set to this value. This is
12730 in general a good idea as it influences both Net::FTP and LWP based
12731 connections. The same effect can be achieved by starting the cpan
12732 shell with this environment variable set. For Net::FTP alone, one can
12733 also always set passive mode by running libnetcfg.
12734
12735 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12736
12737 Populating a freshly installed perl with my favorite modules is pretty
12738 easy if you maintain a private bundle definition file. To get a useful
12739 blueprint of a bundle definition file, the command autobundle can be used
12740 on the CPAN shell command line. This command writes a bundle definition
12741 file for all modules that are installed for the currently running perl
12742 interpreter. It's recommended to run this command only once and from then
12743 on maintain the file manually under a private name, say
12744 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12745
12746     cpan> install Bundle::my_bundle
12747
12748 then answer a few questions and then go out for a coffee.
12749
12750 Maintaining a bundle definition file means keeping track of two
12751 things: dependencies and interactivity. CPAN.pm sometimes fails on
12752 calculating dependencies because not all modules define all MakeMaker
12753 attributes correctly, so a bundle definition file should specify
12754 prerequisites as early as possible. On the other hand, it's a bit
12755 annoying that many distributions need some interactive configuring. So
12756 what I try to accomplish in my private bundle file is to have the
12757 packages that need to be configured early in the file and the gentle
12758 ones later, so I can go out after a few minutes and leave CPAN.pm
12759 untended.
12760
12761 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12762
12763 Thanks to Graham Barr for contributing the following paragraphs about
12764 the interaction between perl, and various firewall configurations. For
12765 further information on firewalls, it is recommended to consult the
12766 documentation that comes with the ncftp program. If you are unable to
12767 go through the firewall with a simple Perl setup, it is very likely
12768 that you can configure ncftp so that it works for your firewall.
12769
12770 =head2 Three basic types of firewalls
12771
12772 Firewalls can be categorized into three basic types.
12773
12774 =over 4
12775
12776 =item http firewall
12777
12778 This is where the firewall machine runs a web server and to access the
12779 outside world you must do it via the web server. If you set environment
12780 variables like http_proxy or ftp_proxy to a values beginning with http://
12781 or in your web browser you have to set proxy information then you know
12782 you are running an http firewall.
12783
12784 To access servers outside these types of firewalls with perl (even for
12785 ftp) you will need to use LWP.
12786
12787 =item ftp firewall
12788
12789 This where the firewall machine runs an ftp server. This kind of
12790 firewall will only let you access ftp servers outside the firewall.
12791 This is usually done by connecting to the firewall with ftp, then
12792 entering a username like "user@outside.host.com"
12793
12794 To access servers outside these type of firewalls with perl you
12795 will need to use Net::FTP.
12796
12797 =item One way visibility
12798
12799 I say one way visibility as these firewalls try to make themselves look
12800 invisible to the users inside the firewall. An FTP data connection is
12801 normally created by sending the remote server your IP address and then
12802 listening for the connection. But the remote server will not be able to
12803 connect to you because of the firewall. So for these types of firewall
12804 FTP connections need to be done in a passive mode.
12805
12806 There are two that I can think off.
12807
12808 =over 4
12809
12810 =item SOCKS
12811
12812 If you are using a SOCKS firewall you will need to compile perl and link
12813 it with the SOCKS library, this is what is normally called a 'socksified'
12814 perl. With this executable you will be able to connect to servers outside
12815 the firewall as if it is not there.
12816
12817 =item IP Masquerade
12818
12819 This is the firewall implemented in the Linux kernel, it allows you to
12820 hide a complete network behind one IP address. With this firewall no
12821 special compiling is needed as you can access hosts directly.
12822
12823 For accessing ftp servers behind such firewalls you usually need to
12824 set the environment variable C<FTP_PASSIVE> or the config variable
12825 ftp_passive to a true value.
12826
12827 =back
12828
12829 =back
12830
12831 =head2 Configuring lynx or ncftp for going through a firewall
12832
12833 If you can go through your firewall with e.g. lynx, presumably with a
12834 command such as
12835
12836     /usr/local/bin/lynx -pscott:tiger
12837
12838 then you would configure CPAN.pm with the command
12839
12840     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12841
12842 That's all. Similarly for ncftp or ftp, you would configure something
12843 like
12844
12845     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12846
12847 Your mileage may vary...
12848
12849 =head1 FAQ
12850
12851 =over 4
12852
12853 =item 1)
12854
12855 I installed a new version of module X but CPAN keeps saying,
12856 I have the old version installed
12857
12858 Most probably you B<do> have the old version installed. This can
12859 happen if a module installs itself into a different directory in the
12860 @INC path than it was previously installed. This is not really a
12861 CPAN.pm problem, you would have the same problem when installing the
12862 module manually. The easiest way to prevent this behaviour is to add
12863 the argument C<UNINST=1> to the C<make install> call, and that is why
12864 many people add this argument permanently by configuring
12865
12866   o conf make_install_arg UNINST=1
12867
12868 =item 2)
12869
12870 So why is UNINST=1 not the default?
12871
12872 Because there are people who have their precise expectations about who
12873 may install where in the @INC path and who uses which @INC array. In
12874 fine tuned environments C<UNINST=1> can cause damage.
12875
12876 =item 3)
12877
12878 I want to clean up my mess, and install a new perl along with
12879 all modules I have. How do I go about it?
12880
12881 Run the autobundle command for your old perl and optionally rename the
12882 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12883 with the Configure option prefix, e.g.
12884
12885     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12886
12887 Install the bundle file you produced in the first step with something like
12888
12889     cpan> install Bundle::mybundle
12890
12891 and you're done.
12892
12893 =item 4)
12894
12895 When I install bundles or multiple modules with one command
12896 there is too much output to keep track of.
12897
12898 You may want to configure something like
12899
12900   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12901   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12902
12903 so that STDOUT is captured in a file for later inspection.
12904
12905
12906 =item 5)
12907
12908 I am not root, how can I install a module in a personal directory?
12909
12910 First of all, you will want to use your own configuration, not the one
12911 that your root user installed. If you do not have permission to write
12912 in the cpan directory that root has configured, you will be asked if
12913 you want to create your own config. Answering "yes" will bring you into
12914 CPAN's configuration stage, using the system config for all defaults except
12915 things that have to do with CPAN's work directory, saving your choices to
12916 your MyConfig.pm file.
12917
12918 You can also manually initiate this process with the following command:
12919
12920     % perl -MCPAN -e 'mkmyconfig'
12921
12922 or by running
12923
12924     mkmyconfig
12925
12926 from the CPAN shell.
12927
12928 You will most probably also want to configure something like this:
12929
12930   o conf makepl_arg "LIB=~/myperl/lib \
12931                     INSTALLMAN1DIR=~/myperl/man/man1 \
12932                     INSTALLMAN3DIR=~/myperl/man/man3 \
12933                     INSTALLSCRIPT=~/myperl/bin \
12934                     INSTALLBIN=~/myperl/bin"
12935
12936 and then (oh joy) the equivalent command for Module::Build. That would
12937 be
12938
12939   o conf mbuildpl_arg "--lib=~/myperl/lib \
12940                     --installman1dir=~/myperl/man/man1 \
12941                     --installman3dir=~/myperl/man/man3 \
12942                     --installscript=~/myperl/bin \
12943                     --installbin=~/myperl/bin"
12944
12945 You can make this setting permanent like all C<o conf> settings with
12946 C<o conf commit> or by setting C<auto_commit> beforehand.
12947
12948 You will have to add ~/myperl/man to the MANPATH environment variable
12949 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12950 including
12951
12952   use lib "$ENV{HOME}/myperl/lib";
12953
12954 or setting the PERL5LIB environment variable.
12955
12956 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12957 that for Windows we use the File::HomeDir module that provides an
12958 equivalent to the concept of the home directory on Unix.
12959
12960 Another thing you should bear in mind is that the UNINST parameter can
12961 be dangerous when you are installing into a private area because you
12962 might accidentally remove modules that other people depend on that are
12963 not using the private area.
12964
12965 =item 6)
12966
12967 How to get a package, unwrap it, and make a change before building it?
12968
12969 Have a look at the C<look> (!) command.
12970
12971 =item 7)
12972
12973 I installed a Bundle and had a couple of fails. When I
12974 retried, everything resolved nicely. Can this be fixed to work
12975 on first try?
12976
12977 The reason for this is that CPAN does not know the dependencies of all
12978 modules when it starts out. To decide about the additional items to
12979 install, it just uses data found in the META.yml file or the generated
12980 Makefile. An undetected missing piece breaks the process. But it may
12981 well be that your Bundle installs some prerequisite later than some
12982 depending item and thus your second try is able to resolve everything.
12983 Please note, CPAN.pm does not know the dependency tree in advance and
12984 cannot sort the queue of things to install in a topologically correct
12985 order. It resolves perfectly well IF all modules declare the
12986 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12987 the C<requires> stanza of Module::Build. For bundles which fail and
12988 you need to install often, it is recommended to sort the Bundle
12989 definition file manually.
12990
12991 =item 8)
12992
12993 In our intranet we have many modules for internal use. How
12994 can I integrate these modules with CPAN.pm but without uploading
12995 the modules to CPAN?
12996
12997 Have a look at the CPAN::Site module.
12998
12999 =item 9)
13000
13001 When I run CPAN's shell, I get an error message about things in my
13002 /etc/inputrc (or ~/.inputrc) file.
13003
13004 These are readline issues and can only be fixed by studying readline
13005 configuration on your architecture and adjusting the referenced file
13006 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
13007 and edit them. Quite often harmless changes like uppercasing or
13008 lowercasing some arguments solves the problem.
13009
13010 =item 10)
13011
13012 Some authors have strange characters in their names.
13013
13014 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
13015 expecting ISO-8859-1 charset, a converter can be activated by setting
13016 term_is_latin to a true value in your config file. One way of doing so
13017 would be
13018
13019     cpan> o conf term_is_latin 1
13020
13021 If other charset support is needed, please file a bugreport against
13022 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
13023 the support or maybe UTF-8 terminals become widely available.
13024
13025 Note: this config variable is deprecated and will be removed in a
13026 future version of CPAN.pm. It will be replaced with the conventions
13027 around the family of $LANG and $LC_* environment variables.
13028
13029 =item 11)
13030
13031 When an install fails for some reason and then I correct the error
13032 condition and retry, CPAN.pm refuses to install the module, saying
13033 C<Already tried without success>.
13034
13035 Use the force pragma like so
13036
13037   force install Foo::Bar
13038
13039 Or you can use
13040
13041   look Foo::Bar
13042
13043 and then 'make install' directly in the subshell.
13044
13045 =item 12)
13046
13047 How do I install a "DEVELOPER RELEASE" of a module?
13048
13049 By default, CPAN will install the latest non-developer release of a
13050 module. If you want to install a dev release, you have to specify the
13051 partial path starting with the author id to the tarball you wish to
13052 install, like so:
13053
13054     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
13055
13056 Note that you can use the C<ls> command to get this path listed.
13057
13058 =item 13)
13059
13060 How do I install a module and all its dependencies from the commandline,
13061 without being prompted for anything, despite my CPAN configuration
13062 (or lack thereof)?
13063
13064 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
13065 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
13066 asked any questions at all (assuming the modules you are installing are
13067 nice about obeying that variable as well):
13068
13069     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
13070
13071 =item 14)
13072
13073 How do I create a Module::Build based Build.PL derived from an
13074 ExtUtils::MakeMaker focused Makefile.PL?
13075
13076 http://search.cpan.org/search?query=Module::Build::Convert
13077
13078 http://www.refcnt.org/papers/module-build-convert
13079
13080 =item 15)
13081
13082 I'm frequently irritated with the CPAN shell's inability to help me
13083 select a good mirror.
13084
13085 The urllist config parameter is yours. You can add and remove sites at
13086 will. You should find out which sites have the best uptodateness,
13087 bandwidth, reliability, etc. and are topologically close to you. Some
13088 people prefer fast downloads, others uptodateness, others reliability.
13089 You decide which to try in which order.
13090
13091 Henk P. Penning maintains a site that collects data about CPAN sites:
13092
13093   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
13094
13095 Also, feel free to play with experimental features. Run
13096
13097   o conf init randomize_urllist ftpstats_period ftpstats_size
13098
13099 and choose your favorite parameters. After a few downloads running the
13100 C<hosts> command will probably assist you in choosing the best mirror
13101 sites.
13102
13103 =item 16)
13104
13105 Why do I get asked the same questions every time I start the shell?
13106
13107 You can make your configuration changes permanent by calling the
13108 command C<o conf commit>. Alternatively set the C<auto_commit>
13109 variable to true by running C<o conf init auto_commit> and answering
13110 the following question with yes.
13111
13112 =item 17)
13113
13114 Older versions of CPAN.pm had the original root directory of all
13115 tarballs in the build directory. Now there are always random
13116 characters appended to these directory names. Why was this done?
13117
13118 The random characters are provided by File::Temp and ensure that each
13119 module's individual build directory is unique. This makes running
13120 CPAN.pm in concurrent processes simultaneously safe.
13121
13122 =item 18)
13123
13124 Speaking of the build directory. Do I have to clean it up myself?
13125
13126 You have the choice to set the config variable C<scan_cache> to
13127 C<never>. Then you must clean it up yourself. The other possible
13128 value, C<atstart> only cleans up the build directory when you start
13129 the CPAN shell. If you never start up the CPAN shell, you probably
13130 also have to clean up the build directory yourself.
13131
13132 =back
13133
13134 =head1 COMPATIBILITY
13135
13136 =head2 OLD PERL VERSIONS
13137
13138 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
13139 newer versions. It is getting more and more difficult to get the
13140 minimal prerequisites working on older perls. It is close to
13141 impossible to get the whole Bundle::CPAN working there. If you're in
13142 the position to have only these old versions, be advised that CPAN is
13143 designed to work fine without the Bundle::CPAN installed.
13144
13145 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
13146 compatible with ancient perls and that File::Temp is listed as a
13147 prerequisite but CPAN has reasonable workarounds if it is missing.
13148
13149 =head2 CPANPLUS
13150
13151 This module and its competitor, the CPANPLUS module, are both much
13152 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
13153 more modular but it was never tried to make it compatible with CPAN.pm.
13154
13155 =head1 SECURITY ADVICE
13156
13157 This software enables you to upgrade software on your computer and so
13158 is inherently dangerous because the newly installed software may
13159 contain bugs and may alter the way your computer works or even make it
13160 unusable. Please consider backing up your data before every upgrade.
13161
13162 =head1 BUGS
13163
13164 Please report bugs via L<http://rt.cpan.org/>
13165
13166 Before submitting a bug, please make sure that the traditional method
13167 of building a Perl module package from a shell by following the
13168 installation instructions of that package still works in your
13169 environment.
13170
13171 =head1 AUTHOR
13172
13173 Andreas Koenig C<< <andk@cpan.org> >>
13174
13175 =head1 LICENSE
13176
13177 This program is free software; you can redistribute it and/or
13178 modify it under the same terms as Perl itself.
13179
13180 See L<http://www.perl.com/perl/misc/Artistic.html>
13181
13182 =head1 TRANSLATIONS
13183
13184 Kawai,Takanori provides a Japanese translation of this manpage at
13185 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
13186
13187 =head1 SEE ALSO
13188
13189 L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
13190
13191 =cut
13192
13193