[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/ -> CPAN.pm (source)

   1  # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2  use strict;
   3  package CPAN;
   4  $CPAN::VERSION = '1.9205';
   5  $CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
   6  
   7  use CPAN::HandleConfig;
   8  use CPAN::Version;
   9  use CPAN::Debug;
  10  use CPAN::Queue;
  11  use CPAN::Tarzip;
  12  use CPAN::DeferedCode;
  13  use Carp ();
  14  use Config ();
  15  use Cwd ();
  16  use DirHandle ();
  17  use Exporter ();
  18  use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  19                                      # 5.005_04 does not work without
  20                                      # this
  21  use File::Basename ();
  22  use File::Copy ();
  23  use File::Find;
  24  use File::Path ();
  25  use File::Spec ();
  26  use FileHandle ();
  27  use Fcntl qw(:flock);
  28  use Safe ();
  29  use Sys::Hostname qw(hostname);
  30  use Text::ParseWords ();
  31  use Text::Wrap ();
  32  
  33  sub find_perl ();
  34  
  35  # we need to run chdir all over and we would get at wrong libraries
  36  # there
  37  BEGIN {
  38      if (File::Spec->can("rel2abs")) {
  39          for my $inc (@INC) {
  40              $inc = File::Spec->rel2abs($inc) unless ref $inc;
  41          }
  42      }
  43  }
  44  no lib ".";
  45  
  46  require Mac::BuildTools if $^O eq 'MacOS';
  47  $ENV{PERL5_CPAN_IS_RUNNING}=$$;
  48  $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
  49  
  50  END { $CPAN::End++; &cleanup; }
  51  
  52  $CPAN::Signal ||= 0;
  53  $CPAN::Frontend ||= "CPAN::Shell";
  54  unless (@CPAN::Defaultsites) {
  55      @CPAN::Defaultsites = map {
  56          CPAN::URL->new(TEXT => $_, FROM => "DEF")
  57      }
  58          "http://www.perl.org/CPAN/",
  59              "ftp://ftp.perl.org/pub/CPAN/";
  60  }
  61  # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  62  $CPAN::Perl ||= CPAN::find_perl();
  63  $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  64  $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
  65  $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
  66  
  67  # our globals are getting a mess
  68  use vars qw(
  69              $AUTOLOAD
  70              $Be_Silent
  71              $CONFIG_DIRTY
  72              $Defaultdocs
  73              $Echo_readline
  74              $Frontend
  75              $GOTOSHELL
  76              $HAS_USABLE
  77              $Have_warned
  78              $MAX_RECURSION
  79              $META
  80              $RUN_DEGRADED
  81              $Signal
  82              $SQLite
  83              $Suppress_readline
  84              $VERSION
  85              $autoload_recursion
  86              $term
  87              @Defaultsites
  88              @EXPORT
  89             );
  90  
  91  $MAX_RECURSION = 32;
  92  
  93  @CPAN::ISA = qw(CPAN::Debug Exporter);
  94  
  95  # note that these functions live in CPAN::Shell and get executed via
  96  # AUTOLOAD when called directly
  97  @EXPORT = qw(
  98               autobundle
  99               bundle
 100               clean
 101               cvs_import
 102               expand
 103               force
 104               fforce
 105               get
 106               install
 107               install_tested
 108               is_tested
 109               make
 110               mkmyconfig
 111               notest
 112               perldoc
 113               readme
 114               recent
 115               recompile
 116               report
 117               shell
 118               smoke
 119               test
 120               upgrade
 121              );
 122  
 123  sub soft_chdir_with_alternatives ($);
 124  
 125  {
 126      $autoload_recursion ||= 0;
 127  
 128      #-> sub CPAN::AUTOLOAD ;
 129      sub AUTOLOAD {
 130          $autoload_recursion++;
 131          my($l) = $AUTOLOAD;
 132          $l =~ s/.*:://;
 133          if ($CPAN::Signal) {
 134              warn "Refusing to autoload '$l' while signal pending";
 135              $autoload_recursion--;
 136              return;
 137          }
 138          if ($autoload_recursion > 1) {
 139              my $fullcommand = join " ", map { "'$_'" } $l, @_;
 140              warn "Refusing to autoload $fullcommand in recursion\n";
 141              $autoload_recursion--;
 142              return;
 143          }
 144          my(%export);
 145          @export{@EXPORT} = '';
 146          CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 147          if (exists $export{$l}) {
 148              CPAN::Shell->$l(@_);
 149          } else {
 150              die(qq{Unknown CPAN command "$AUTOLOAD". }.
 151                  qq{Type ? for help.\n});
 152          }
 153          $autoload_recursion--;
 154      }
 155  }
 156  
 157  #-> sub CPAN::shell ;
 158  sub shell {
 159      my($self) = @_;
 160      $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 161      CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 162  
 163      my $oprompt = shift || CPAN::Prompt->new;
 164      my $prompt = $oprompt;
 165      my $commandline = shift || "";
 166      $CPAN::CurrentCommandId ||= 1;
 167  
 168      local($^W) = 1;
 169      unless ($Suppress_readline) {
 170          require Term::ReadLine;
 171          if (! $term
 172              or
 173              $term->ReadLine eq "Term::ReadLine::Stub"
 174             ) {
 175              $term = Term::ReadLine->new('CPAN Monitor');
 176          }
 177          if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 178              my $attribs = $term->Attribs;
 179              $attribs->{attempted_completion_function} = sub {
 180                  &CPAN::Complete::gnu_cpl;
 181              }
 182          } else {
 183              $readline::rl_completion_function =
 184                  $readline::rl_completion_function = 'CPAN::Complete::cpl';
 185          }
 186          if (my $histfile = $CPAN::Config->{'histfile'}) {{
 187              unless ($term->can("AddHistory")) {
 188                  $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 189                  last;
 190              }
 191              $META->readhist($term,$histfile);
 192          }}
 193          for ($CPAN::Config->{term_ornaments}) { # alias
 194              local $Term::ReadLine::termcap_nowarn = 1;
 195              $term->ornaments($_) if defined;
 196          }
 197          # $term->OUT is autoflushed anyway
 198          my $odef = select STDERR;
 199          $| = 1;
 200          select STDOUT;
 201          $| = 1;
 202          select $odef;
 203      }
 204  
 205      $META->checklock();
 206      my @cwd = grep { defined $_ and length $_ }
 207          CPAN::anycwd(),
 208                File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 209                      File::Spec->rootdir();
 210      my $try_detect_readline;
 211      $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 212      unless ($CPAN::Config->{inhibit_startup_message}) {
 213          my $rl_avail = $Suppress_readline ? "suppressed" :
 214              ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 215                  "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
 216          $CPAN::Frontend->myprint(
 217                                   sprintf qq{
 218  cpan shell -- CPAN exploration and modules installation (v%s)
 219  ReadLine support %s
 220  
 221  },
 222                                   $CPAN::VERSION,
 223                                   $rl_avail
 224                                  )
 225      }
 226      my($continuation) = "";
 227      my $last_term_ornaments;
 228    SHELLCOMMAND: while () {
 229          if ($Suppress_readline) {
 230              if ($Echo_readline) {
 231                  $|=1;
 232              }
 233              print $prompt;
 234              last SHELLCOMMAND unless defined ($_ = <> );
 235              if ($Echo_readline) {
 236                  # backdoor: I could not find a way to record sessions
 237                  print $_;
 238              }
 239              chomp;
 240          } else {
 241              last SHELLCOMMAND unless
 242                  defined ($_ = $term->readline($prompt, $commandline));
 243          }
 244          $_ = "$continuation$_" if $continuation;
 245          s/^\s+//;
 246          next SHELLCOMMAND if /^$/;
 247          s/^\s*\?\s*/help /;
 248          if (/^(?:q(?:uit)?|bye|exit)$/i) {
 249              last SHELLCOMMAND;
 250          } elsif (s/\\$//s) {
 251              chomp;
 252              $continuation = $_;
 253              $prompt = "    > ";
 254          } elsif (/^\!/) {
 255              s/^\!//;
 256              my($eval) = $_;
 257              package CPAN::Eval;
 258              use strict;
 259              use vars qw($import_done);
 260              CPAN->import(':DEFAULT') unless $import_done++;
 261              CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 262              eval($eval);
 263              warn $@ if $@;
 264              $continuation = "";
 265              $prompt = $oprompt;
 266          } elsif (/./) {
 267              my(@line);
 268              eval { @line = Text::ParseWords::shellwords($_) };
 269              warn($@), next SHELLCOMMAND if $@;
 270              warn("Text::Parsewords could not parse the line [$_]"),
 271                  next SHELLCOMMAND unless @line;
 272              $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 273              my $command = shift @line;
 274              eval { CPAN::Shell->$command(@line) };
 275              if ($@) {
 276                  my $err = "$@";
 277                  if ($err =~ /\S/) {
 278                      require Carp;
 279                      require Dumpvalue;
 280                      my $dv = Dumpvalue->new();
 281                      Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
 282                  }
 283              }
 284              if ($command =~ /^(
 285                               # classic commands
 286                               make
 287                               |test
 288                               |install
 289                               |clean
 290  
 291                               # pragmas for classic commands
 292                               |ff?orce
 293                               |notest
 294  
 295                               # compounds
 296                               |report
 297                               |smoke
 298                               |upgrade
 299                              )$/x) {
 300                  # only commands that tell us something about failed distros
 301                  CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 302              }
 303              soft_chdir_with_alternatives(\@cwd);
 304              $CPAN::Frontend->myprint("\n");
 305              $continuation = "";
 306              $CPAN::CurrentCommandId++;
 307              $prompt = $oprompt;
 308          }
 309      } continue {
 310          $commandline = ""; # I do want to be able to pass a default to
 311                             # shell, but on the second command I see no
 312                             # use in that
 313          $Signal=0;
 314          CPAN::Queue->nullify_queue;
 315          if ($try_detect_readline) {
 316              if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 317                  ||
 318                  $CPAN::META->has_inst("Term::ReadLine::Perl")
 319              ) {
 320                  delete $INC{"Term/ReadLine.pm"};
 321                  my $redef = 0;
 322                  local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 323                  require Term::ReadLine;
 324                  $CPAN::Frontend->myprint("\n$redef subroutines in ".
 325                                           "Term::ReadLine redefined\n");
 326                  $GOTOSHELL = 1;
 327              }
 328          }
 329          if ($term and $term->can("ornaments")) {
 330              for ($CPAN::Config->{term_ornaments}) { # alias
 331                  if (defined $_) {
 332                      if (not defined $last_term_ornaments
 333                          or $_ != $last_term_ornaments
 334                      ) {
 335                          local $Term::ReadLine::termcap_nowarn = 1;
 336                          $term->ornaments($_);
 337                          $last_term_ornaments = $_;
 338                      }
 339                  } else {
 340                      undef $last_term_ornaments;
 341                  }
 342              }
 343          }
 344          for my $class (qw(Module Distribution)) {
 345              # again unsafe meta access?
 346              for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 347                  next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 348                  CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 349                  delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 350              }
 351          }
 352          if ($GOTOSHELL) {
 353              $GOTOSHELL = 0; # not too often
 354              $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 355              @_ = ($oprompt,"");
 356              goto &shell;
 357          }
 358      }
 359      soft_chdir_with_alternatives(\@cwd);
 360  }
 361  
 362  #-> CPAN::soft_chdir_with_alternatives ;
 363  sub soft_chdir_with_alternatives ($) {
 364      my($cwd) = @_;
 365      unless (@$cwd) {
 366          my $root = File::Spec->rootdir();
 367          $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 368  Trying '$root' as temporary haven.
 369  });
 370          push @$cwd, $root;
 371      }
 372      while () {
 373          if (chdir $cwd->[0]) {
 374              return;
 375          } else {
 376              if (@$cwd>1) {
 377                  $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 378  Trying to chdir to "$cwd->[1]" instead.
 379  });
 380                  shift @$cwd;
 381              } else {
 382                  $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 383              }
 384          }
 385      }
 386  }
 387  
 388  sub _flock {
 389      my($fh,$mode) = @_;
 390      if ($Config::Config{d_flock}) {
 391          return flock $fh, $mode;
 392      } elsif (!$Have_warned->{"d_flock"}++) {
 393          $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
 394          $CPAN::Frontend->mysleep(5);
 395          return 1;
 396      } else {
 397          return 1;
 398      }
 399  }
 400  
 401  sub _yaml_module () {
 402      my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 403      if (
 404          $yaml_module ne "YAML"
 405          &&
 406          !$CPAN::META->has_inst($yaml_module)
 407         ) {
 408          # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 409          $yaml_module = "YAML";
 410      }
 411      if ($yaml_module eq "YAML"
 412          &&
 413          $CPAN::META->has_inst($yaml_module)
 414          &&
 415          $YAML::VERSION < 0.60
 416          &&
 417          !$Have_warned->{"YAML"}++
 418         ) {
 419          $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 420                                  "I'll continue but problems are *very* likely to happen.\n"
 421                                 );
 422          $CPAN::Frontend->mysleep(5);
 423      }
 424      return $yaml_module;
 425  }
 426  
 427  # CPAN::_yaml_loadfile
 428  sub _yaml_loadfile {
 429      my($self,$local_file) = @_;
 430      return +[] unless -s $local_file;
 431      my $yaml_module = _yaml_module;
 432      if ($CPAN::META->has_inst($yaml_module)) {
 433          # temporarly enable yaml code deserialisation
 434          no strict 'refs';
 435          # 5.6.2 could not do the local() with the reference
 436          local $YAML::LoadCode;
 437          local $YAML::Syck::LoadCode;
 438          ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
 439  
 440          my $code;
 441          if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 442              my @yaml;
 443              eval { @yaml = $code->($local_file); };
 444              if ($@) {
 445                  # this shall not be done by the frontend
 446                  die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 447              }
 448              return \@yaml;
 449          } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 450              local *FH;
 451              open FH, $local_file or die "Could not open '$local_file': $!";
 452              local $/;
 453              my $ystream = <FH>;
 454              my @yaml;
 455              eval { @yaml = $code->($ystream); };
 456              if ($@) {
 457                  # this shall not be done by the frontend
 458                  die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 459              }
 460              return \@yaml;
 461          }
 462      } else {
 463          # this shall not be done by the frontend
 464          die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 465      }
 466      return +[];
 467  }
 468  
 469  # CPAN::_yaml_dumpfile
 470  sub _yaml_dumpfile {
 471      my($self,$local_file,@what) = @_;
 472      my $yaml_module = _yaml_module;
 473      if ($CPAN::META->has_inst($yaml_module)) {
 474          my $code;
 475          if (UNIVERSAL::isa($local_file, "FileHandle")) {
 476              $code = UNIVERSAL::can($yaml_module, "Dump");
 477              eval { print $local_file $code->(@what) };
 478          } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 479              eval { $code->($local_file,@what); };
 480          } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 481              local *FH;
 482              open FH, ">$local_file" or die "Could not open '$local_file': $!";
 483              print FH $code->(@what);
 484          }
 485          if ($@) {
 486              die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 487          }
 488      } else {
 489          if (UNIVERSAL::isa($local_file, "FileHandle")) {
 490              # I think this case does not justify a warning at all
 491          } else {
 492              die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 493          }
 494      }
 495  }
 496  
 497  sub _init_sqlite () {
 498      unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 499          $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 500              unless $Have_warned->{"CPAN::SQLite"}++;
 501          return;
 502      }
 503      require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 504      $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 505  }
 506  
 507  {
 508      my $negative_cache = {};
 509      sub _sqlite_running {
 510          if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 511              # need to cache the result, otherwise too slow
 512              return $negative_cache->{fact};
 513          } else {
 514              $negative_cache = {}; # reset
 515          }
 516          my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 517          return $ret if $ret; # fast anyway
 518          $negative_cache->{time} = time;
 519          return $negative_cache->{fact} = $ret;
 520      }
 521  }
 522  
 523  package CPAN::CacheMgr;
 524  use strict;
 525  @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 526  use File::Find;
 527  
 528  package CPAN::FTP;
 529  use strict;
 530  use Fcntl qw(:flock);
 531  use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
 532  @CPAN::FTP::ISA = qw(CPAN::Debug);
 533  
 534  package CPAN::LWP::UserAgent;
 535  use strict;
 536  use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 537  # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 538  
 539  package CPAN::Complete;
 540  use strict;
 541  @CPAN::Complete::ISA = qw(CPAN::Debug);
 542  # Q: where is the "How do I add a new command" HOWTO?
 543  # A: svn diff -r 1048:1049 where andk added the report command
 544  @CPAN::Complete::COMMANDS = sort qw(
 545                                      ? ! a b d h i m o q r u
 546                                      autobundle
 547                                      bye
 548                                      clean
 549                                      cvs_import
 550                                      dump
 551                                      exit
 552                                      failed
 553                                      force
 554                                      fforce
 555                                      hosts
 556                                      install
 557                                      install_tested
 558                                      is_tested
 559                                      look
 560                                      ls
 561                                      make
 562                                      mkmyconfig
 563                                      notest
 564                                      perldoc
 565                                      quit
 566                                      readme
 567                                      recent
 568                                      recompile
 569                                      reload
 570                                      report
 571                                      reports
 572                                      scripts
 573                                      smoke
 574                                      test
 575                                      upgrade
 576  );
 577  
 578  package CPAN::Index;
 579  use strict;
 580  use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 581  @CPAN::Index::ISA = qw(CPAN::Debug);
 582  $LAST_TIME ||= 0;
 583  $DATE_OF_03 ||= 0;
 584  # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 585  sub PROTOCOL { 2.0 }
 586  
 587  package CPAN::InfoObj;
 588  use strict;
 589  @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 590  
 591  package CPAN::Author;
 592  use strict;
 593  @CPAN::Author::ISA = qw(CPAN::InfoObj);
 594  
 595  package CPAN::Distribution;
 596  use strict;
 597  @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 598  
 599  package CPAN::Bundle;
 600  use strict;
 601  @CPAN::Bundle::ISA = qw(CPAN::Module);
 602  
 603  package CPAN::Module;
 604  use strict;
 605  @CPAN::Module::ISA = qw(CPAN::InfoObj);
 606  
 607  package CPAN::Exception::RecursiveDependency;
 608  use strict;
 609  use overload '""' => "as_string";
 610  
 611  # a module sees its distribution (no version)
 612  # a distribution sees its prereqs (which are module names) (usually with versions)
 613  # a bundle sees its module names and/or its distributions (no version)
 614  
 615  sub new {
 616      my($class) = shift;
 617      my($deps) = shift;
 618      my (@deps,%seen,$loop_starts_with);
 619    DCHAIN: for my $dep (@$deps) {
 620          push @deps, {name => $dep, display_as => $dep};
 621          if ($seen{$dep}++) {
 622              $loop_starts_with = $dep;
 623              last DCHAIN;
 624          }
 625      }
 626      my $in_loop = 0;
 627      for my $i (0..$#deps) {
 628          my $x = $deps[$i]{name};
 629          $in_loop ||= $x eq $loop_starts_with;
 630          my $xo = CPAN::Shell->expandany($x) or next;
 631          if ($xo->isa("CPAN::Module")) {
 632              my $have = $xo->inst_version || "N/A";
 633              my($want,$d,$want_type);
 634              if ($i>0 and $d = $deps[$i-1]{name}) {
 635                  my $do = CPAN::Shell->expandany($d);
 636                  $want = $do->{prereq_pm}{requires}{$x};
 637                  if (defined $want) {
 638                      $want_type = "requires: ";
 639                  } else {
 640                      $want = $do->{prereq_pm}{build_requires}{$x};
 641                      if (defined $want) {
 642                          $want_type = "build_requires: ";
 643                      } else {
 644                          $want_type = "unknown status";
 645                          $want = "???";
 646                      }
 647                  }
 648              } else {
 649                  $want = $xo->cpan_version;
 650                  $want_type = "want: ";
 651              }
 652              $deps[$i]{have} = $have;
 653              $deps[$i]{want_type} = $want_type;
 654              $deps[$i]{want} = $want;
 655              $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 656          } elsif ($xo->isa("CPAN::Distribution")) {
 657              $deps[$i]{display_as} = $xo->pretty_id;
 658              if ($in_loop) {
 659                  $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 660              } else {
 661                  $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 662              }
 663              $xo->store_persistent_state; # otherwise I will not reach
 664                                           # all involved parties for
 665                                           # the next session
 666          }
 667      }
 668      bless { deps => \@deps }, $class;
 669  }
 670  
 671  sub as_string {
 672      my($self) = shift;
 673      my $ret = "\nRecursive dependency detected:\n    ";
 674      $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 675      $ret .= ".\nCannot resolve.\n";
 676      $ret;
 677  }
 678  
 679  package CPAN::Exception::yaml_not_installed;
 680  use strict;
 681  use overload '""' => "as_string";
 682  
 683  sub new {
 684      my($class,$module,$file,$during) = @_;
 685      bless { module => $module, file => $file, during => $during }, $class;
 686  }
 687  
 688  sub as_string {
 689      my($self) = shift;
 690      "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 691  }
 692  
 693  package CPAN::Exception::yaml_process_error;
 694  use strict;
 695  use overload '""' => "as_string";
 696  
 697  sub new {
 698      my($class,$module,$file,$during,$error) = @_;
 699      bless { module => $module,
 700              file => $file,
 701              during => $during,
 702              error => $error }, $class;
 703  }
 704  
 705  sub as_string {
 706      my($self) = shift;
 707      if ($self->{during}) {
 708          if ($self->{file}) {
 709              if ($self->{module}) {
 710                  if ($self->{error}) {
 711                      return "Alert: While trying to '$self->{during}' YAML file\n".
 712                          " '$self->{file}'\n".
 713                              "with '$self->{module}' the following error was encountered:\n".
 714                                  "  $self->{error}\n";
 715                  } else {
 716                      return "Alert: While trying to '$self->{during}' YAML file\n".
 717                          " '$self->{file}'\n".
 718                              "with '$self->{module}' some unknown error was encountered\n";
 719                  }
 720              } else {
 721                  return "Alert: While trying to '$self->{during}' YAML file\n".
 722                      " '$self->{file}'\n".
 723                          "some unknown error was encountered\n";
 724              }
 725          } else {
 726              return "Alert: While trying to '$self->{during}' some YAML file\n".
 727                      "some unknown error was encountered\n";
 728          }
 729      } else {
 730          return "Alert: unknown error encountered\n";
 731      }
 732  }
 733  
 734  package CPAN::Prompt; use overload '""' => "as_string";
 735  use vars qw($prompt);
 736  $prompt = "cpan> ";
 737  $CPAN::CurrentCommandId ||= 0;
 738  sub new {
 739      bless {}, shift;
 740  }
 741  sub as_string {
 742      my $word = "cpan";
 743      unless ($CPAN::META->{LOCK}) {
 744          $word = "nolock_cpan";
 745      }
 746      if ($CPAN::Config->{commandnumber_in_prompt}) {
 747          sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 748      } else {
 749          "$word> ";
 750      }
 751  }
 752  
 753  package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 754  # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 755  # planned are things like age or quality
 756  sub new {
 757      my($class,%args) = @_;
 758      bless {
 759             %args
 760            }, $class;
 761  }
 762  sub as_string {
 763      my($self) = @_;
 764      $self->text;
 765  }
 766  sub text {
 767      my($self,$set) = @_;
 768      if (defined $set) {
 769          $self->{TEXT} = $set;
 770      }
 771      $self->{TEXT};
 772  }
 773  
 774  package CPAN::Distrostatus;
 775  use overload '""' => "as_string",
 776      fallback => 1;
 777  sub new {
 778      my($class,$arg) = @_;
 779      bless {
 780             TEXT => $arg,
 781             FAILED => substr($arg,0,2) eq "NO",
 782             COMMANDID => $CPAN::CurrentCommandId,
 783             TIME => time,
 784            }, $class;
 785  }
 786  sub commandid { shift->{COMMANDID} }
 787  sub failed { shift->{FAILED} }
 788  sub text {
 789      my($self,$set) = @_;
 790      if (defined $set) {
 791          $self->{TEXT} = $set;
 792      }
 793      $self->{TEXT};
 794  }
 795  sub as_string {
 796      my($self) = @_;
 797      $self->text;
 798  }
 799  
 800  package CPAN::Shell;
 801  use strict;
 802  use vars qw(
 803              $ADVANCED_QUERY
 804              $AUTOLOAD
 805              $COLOR_REGISTERED
 806              $Help
 807              $autoload_recursion
 808              $reload
 809              @ISA
 810             );
 811  @CPAN::Shell::ISA = qw(CPAN::Debug);
 812  $COLOR_REGISTERED ||= 0;
 813  $Help = {
 814           '?' => \"help",
 815           '!' => "eval the rest of the line as perl",
 816           a => "whois author",
 817           autobundle => "wtite inventory into a bundle file",
 818           b => "info about bundle",
 819           bye => \"quit",
 820           clean => "clean up a distribution's build directory",
 821           # cvs_import
 822           d => "info about a distribution",
 823           # dump
 824           exit => \"quit",
 825           failed => "list all failed actions within current session",
 826           fforce => "redo a command from scratch",
 827           force => "redo a command",
 828           h => \"help",
 829           help => "overview over commands; 'help ...' explains specific commands",
 830           hosts => "statistics about recently used hosts",
 831           i => "info about authors/bundles/distributions/modules",
 832           install => "install a distribution",
 833           install_tested => "install all distributions tested OK",
 834           is_tested => "list all distributions tested OK",
 835           look => "open a subshell in a distribution's directory",
 836           ls => "list distributions according to a glob",
 837           m => "info about a module",
 838           make => "make/build a distribution",
 839           mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 840           notest => "run a (usually install) command but leave out the test phase",
 841           o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 842           perldoc => "try to get a manpage for a module",
 843           q => \"quit",
 844           quit => "leave the cpan shell",
 845           r => "review over upgradeable modules",
 846           readme => "display the README of a distro woth a pager",
 847           recent => "show recent uploads to the CPAN",
 848           # recompile
 849           reload => "'reload cpan' or 'reload index'",
 850           report => "test a distribution and send a test report to cpantesters",
 851           reports => "info about reported tests from cpantesters",
 852           # scripts
 853           # smoke
 854           test => "test a distribution",
 855           u => "display uninstalled modules",
 856           upgrade => "combine 'r' command with immediate installation",
 857          };
 858  {
 859      $autoload_recursion   ||= 0;
 860  
 861      #-> sub CPAN::Shell::AUTOLOAD ;
 862      sub AUTOLOAD {
 863          $autoload_recursion++;
 864          my($l) = $AUTOLOAD;
 865          my $class = shift(@_);
 866          # warn "autoload[$l] class[$class]";
 867          $l =~ s/.*:://;
 868          if ($CPAN::Signal) {
 869              warn "Refusing to autoload '$l' while signal pending";
 870              $autoload_recursion--;
 871              return;
 872          }
 873          if ($autoload_recursion > 1) {
 874              my $fullcommand = join " ", map { "'$_'" } $l, @_;
 875              warn "Refusing to autoload $fullcommand in recursion\n";
 876              $autoload_recursion--;
 877              return;
 878          }
 879          if ($l =~ /^w/) {
 880              # XXX needs to be reconsidered
 881              if ($CPAN::META->has_inst('CPAN::WAIT')) {
 882                  CPAN::WAIT->$l(@_);
 883              } else {
 884                  $CPAN::Frontend->mywarn(qq{
 885  Commands starting with "w" require CPAN::WAIT to be installed.
 886  Please consider installing CPAN::WAIT to use the fulltext index.
 887  For this you just need to type
 888      install CPAN::WAIT
 889  });
 890              }
 891          } else {
 892              $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 893                                      qq{Type ? for help.
 894  });
 895          }
 896          $autoload_recursion--;
 897      }
 898  }
 899  
 900  package CPAN;
 901  use strict;
 902  
 903  $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 904  
 905  # from here on only subs.
 906  ################################################################################
 907  
 908  sub _perl_fingerprint {
 909      my($self,$other_fingerprint) = @_;
 910      my $dll = eval {OS2::DLLname()};
 911      my $mtime_dll = 0;
 912      if (defined $dll) {
 913          $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 914      }
 915      my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
 916      my $this_fingerprint = {
 917                              '$^X' => CPAN::find_perl,
 918                              sitearchexp => $Config::Config{sitearchexp},
 919                              'mtime_$^X' => $mtime_perl,
 920                              'mtime_dll' => $mtime_dll,
 921                             };
 922      if ($other_fingerprint) {
 923          if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 924              $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 925          }
 926          # mandatory keys since 1.88_57
 927          for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 928              return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 929          }
 930          return 1;
 931      } else {
 932          return $this_fingerprint;
 933      }
 934  }
 935  
 936  sub suggest_myconfig () {
 937    SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 938          $CPAN::Frontend->myprint("You don't seem to have a user ".
 939                                   "configuration (MyConfig.pm) yet.\n");
 940          my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 941                                                "user configuration now? (Y/n)",
 942                                                "yes");
 943          if($new =~ m{^y}i) {
 944              CPAN::Shell->mkmyconfig();
 945              return &checklock;
 946          } else {
 947              $CPAN::Frontend->mydie("OK, giving up.");
 948          }
 949      }
 950  }
 951  
 952  #-> sub CPAN::all_objects ;
 953  sub all_objects {
 954      my($mgr,$class) = @_;
 955      CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 956      CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 957      CPAN::Index->reload;
 958      values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 959  }
 960  
 961  # Called by shell, not in batch mode. In batch mode I see no risk in
 962  # having many processes updating something as installations are
 963  # continually checked at runtime. In shell mode I suspect it is
 964  # unintentional to open more than one shell at a time
 965  
 966  #-> sub CPAN::checklock ;
 967  sub checklock {
 968      my($self) = @_;
 969      my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 970      if (-f $lockfile && -M _ > 0) {
 971          my $fh = FileHandle->new($lockfile) or
 972              $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 973          my $otherpid  = <$fh>;
 974          my $otherhost = <$fh>;
 975          $fh->close;
 976          if (defined $otherpid && $otherpid) {
 977              chomp $otherpid;
 978          }
 979          if (defined $otherhost && $otherhost) {
 980              chomp $otherhost;
 981          }
 982          my $thishost  = hostname();
 983          if (defined $otherhost && defined $thishost &&
 984              $otherhost ne '' && $thishost ne '' &&
 985              $otherhost ne $thishost) {
 986              $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 987                                             "reports other host $otherhost and other ".
 988                                             "process $otherpid.\n".
 989                                             "Cannot proceed.\n"));
 990          } elsif ($RUN_DEGRADED) {
 991              $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 992          } elsif (defined $otherpid && $otherpid) {
 993              return if $$ == $otherpid; # should never happen
 994              $CPAN::Frontend->mywarn(
 995                                      qq{
 996  There seems to be running another CPAN process (pid $otherpid).  Contacting...
 997  });
 998              if (kill 0, $otherpid) {
 999                  $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1000                  my($ans) =
1001                      CPAN::Shell::colorable_makemaker_prompt
1002                          (qq{Shall I try to run in degraded }.
1003                          qq{mode? (Y/n)},"y");
1004                  if ($ans =~ /^y/i) {
1005                      $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1006  Please report if something unexpected happens\n");
1007                      $RUN_DEGRADED = 1;
1008                      for ($CPAN::Config) {
1009                          # XXX
1010                          # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1011                          $_->{commandnumber_in_prompt} = 0; # visibility
1012                          $_->{histfile} = "";               # who should win otherwise?
1013                          $_->{cache_metadata} = 0;          # better would be a lock?
1014                          $_->{use_sqlite} = 0;              # better would be a write lock!
1015                      }
1016                  } else {
1017                      $CPAN::Frontend->mydie("
1018  You may want to kill the other job and delete the lockfile. On UNIX try:
1019      kill $otherpid
1020      rm $lockfile
1021  ");
1022                  }
1023              } elsif (-w $lockfile) {
1024                  my($ans) =
1025                      CPAN::Shell::colorable_makemaker_prompt
1026                          (qq{Other job not responding. Shall I overwrite }.
1027                          qq{the lockfile '$lockfile'? (Y/n)},"y");
1028              $CPAN::Frontend->myexit("Ok, bye\n")
1029                  unless $ans =~ /^y/i;
1030              } else {
1031                  Carp::croak(
1032                      qq{Lockfile '$lockfile' not writeable by you. }.
1033                      qq{Cannot proceed.\n}.
1034                      qq{    On UNIX try:\n}.
1035                      qq{    rm '$lockfile'\n}.
1036                      qq{  and then rerun us.\n}
1037                  );
1038              }
1039          } else {
1040              $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1041                                             "'$lockfile', please remove. Cannot proceed.\n"));
1042          }
1043      }
1044      my $dotcpan = $CPAN::Config->{cpan_home};
1045      eval { File::Path::mkpath($dotcpan);};
1046      if ($@) {
1047          # A special case at least for Jarkko.
1048          my $firsterror = $@;
1049          my $seconderror;
1050          my $symlinkcpan;
1051          if (-l $dotcpan) {
1052              $symlinkcpan = readlink $dotcpan;
1053              die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1054              eval { File::Path::mkpath($symlinkcpan); };
1055              if ($@) {
1056                  $seconderror = $@;
1057              } else {
1058                  $CPAN::Frontend->mywarn(qq{
1059  Working directory $symlinkcpan created.
1060  });
1061              }
1062          }
1063          unless (-d $dotcpan) {
1064              my $mess = qq{
1065  Your configuration suggests "$dotcpan" as your
1066  CPAN.pm working directory. I could not create this directory due
1067  to this error: $firsterror\n};
1068              $mess .= qq{
1069  As "$dotcpan" is a symlink to "$symlinkcpan",
1070  I tried to create that, but I failed with this error: $seconderror
1071  } if $seconderror;
1072              $mess .= qq{
1073  Please make sure the directory exists and is writable.
1074  };
1075              $CPAN::Frontend->mywarn($mess);
1076              return suggest_myconfig;
1077          }
1078      } # $@ after eval mkpath $dotcpan
1079      if (0) { # to test what happens when a race condition occurs
1080          for (reverse 1..10) {
1081              print $_, "\n";
1082              sleep 1;
1083          }
1084      }
1085      # locking
1086      if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1087          my $fh;
1088          unless ($fh = FileHandle->new("+>>$lockfile")) {
1089              if ($! =~ /Permission/) {
1090                  $CPAN::Frontend->mywarn(qq{
1091  
1092  Your configuration suggests that CPAN.pm should use a working
1093  directory of
1094      $CPAN::Config->{cpan_home}
1095  Unfortunately we could not create the lock file
1096      $lockfile
1097  due to permission problems.
1098  
1099  Please make sure that the configuration variable
1100      \$CPAN::Config->{cpan_home}
1101  points to a directory where you can write a .lock file. You can set
1102  this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1103  \@INC path;
1104  });
1105                  return suggest_myconfig;
1106              }
1107          }
1108          my $sleep = 1;
1109          while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1110              if ($sleep>10) {
1111                  $CPAN::Frontend->mydie("Giving up\n");
1112              }
1113              $CPAN::Frontend->mysleep($sleep++);
1114              $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1115          }
1116  
1117          seek $fh, 0, 0;
1118          truncate $fh, 0;
1119          $fh->autoflush(1);
1120          $fh->print($$, "\n");
1121          $fh->print(hostname(), "\n");
1122          $self->{LOCK} = $lockfile;
1123          $self->{LOCKFH} = $fh;
1124      }
1125      $SIG{TERM} = sub {
1126          my $sig = shift;
1127          &cleanup;
1128          $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1129      };
1130      $SIG{INT} = sub {
1131        # no blocks!!!
1132          my $sig = shift;
1133          &cleanup if $Signal;
1134          die "Got yet another signal" if $Signal > 1;
1135          $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1136          $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1137          $Signal++;
1138      };
1139  
1140  #       From: Larry Wall <larry@wall.org>
1141  #       Subject: Re: deprecating SIGDIE
1142  #       To: perl5-porters@perl.org
1143  #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1144  #
1145  #       The original intent of __DIE__ was only to allow you to substitute one
1146  #       kind of death for another on an application-wide basis without respect
1147  #       to whether you were in an eval or not.  As a global backstop, it should
1148  #       not be used any more lightly (or any more heavily :-) than class
1149  #       UNIVERSAL.  Any attempt to build a general exception model on it should
1150  #       be politely squashed.  Any bug that causes every eval {} to have to be
1151  #       modified should be not so politely squashed.
1152  #
1153  #       Those are my current opinions.  It is also my optinion that polite
1154  #       arguments degenerate to personal arguments far too frequently, and that
1155  #       when they do, it's because both people wanted it to, or at least didn't
1156  #       sufficiently want it not to.
1157  #
1158  #       Larry
1159  
1160      # global backstop to cleanup if we should really die
1161      $SIG{__DIE__} = \&cleanup;
1162      $self->debug("Signal handler set.") if $CPAN::DEBUG;
1163  }
1164  
1165  #-> sub CPAN::DESTROY ;
1166  sub DESTROY {
1167      &cleanup; # need an eval?
1168  }
1169  
1170  #-> sub CPAN::anycwd ;
1171  sub anycwd () {
1172      my $getcwd;
1173      $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1174      CPAN->$getcwd();
1175  }
1176  
1177  #-> sub CPAN::cwd ;
1178  sub cwd {Cwd::cwd();}
1179  
1180  #-> sub CPAN::getcwd ;
1181  sub getcwd {Cwd::getcwd();}
1182  
1183  #-> sub CPAN::fastcwd ;
1184  sub fastcwd {Cwd::fastcwd();}
1185  
1186  #-> sub CPAN::backtickcwd ;
1187  sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1188  
1189  #-> sub CPAN::find_perl ;
1190  sub find_perl () {
1191      my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1192      my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1193      my $candidate = File::Spec->catfile($pwd,$^X);
1194      $perl ||= $candidate if MM->maybe_command($candidate);
1195  
1196      unless ($perl) {
1197          my ($component,$perl_name);
1198        DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1199            PATH_COMPONENT: foreach $component (File::Spec->path(),
1200                                                  $Config::Config{'binexp'}) {
1201                  next unless defined($component) && $component;
1202                  my($abs) = File::Spec->catfile($component,$perl_name);
1203                  if (MM->maybe_command($abs)) {
1204                      $perl = $abs;
1205                      last DIST_PERLNAME;
1206                  }
1207              }
1208          }
1209      }
1210  
1211      return $perl;
1212  }
1213  
1214  
1215  #-> sub CPAN::exists ;
1216  sub exists {
1217      my($mgr,$class,$id) = @_;
1218      CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1219      CPAN::Index->reload;
1220      ### Carp::croak "exists called without class argument" unless $class;
1221      $id ||= "";
1222      $id =~ s/:+/::/g if $class eq "CPAN::Module";
1223      my $exists;
1224      if (CPAN::_sqlite_running) {
1225          $exists = (exists $META->{readonly}{$class}{$id} or
1226                     $CPAN::SQLite->set($class, $id));
1227      } else {
1228          $exists =  exists $META->{readonly}{$class}{$id};
1229      }
1230      $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1231  }
1232  
1233  #-> sub CPAN::delete ;
1234  sub delete {
1235    my($mgr,$class,$id) = @_;
1236    delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1237    delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1238  }
1239  
1240  #-> sub CPAN::has_usable
1241  # has_inst is sometimes too optimistic, we should replace it with this
1242  # has_usable whenever a case is given
1243  sub has_usable {
1244      my($self,$mod,$message) = @_;
1245      return 1 if $HAS_USABLE->{$mod};
1246      my $has_inst = $self->has_inst($mod,$message);
1247      return unless $has_inst;
1248      my $usable;
1249      $usable = {
1250                 LWP => [ # we frequently had "Can't locate object
1251                          # method "new" via package "LWP::UserAgent" at
1252                          # (eval 69) line 2006
1253                         sub {require LWP},
1254                         sub {require LWP::UserAgent},
1255                         sub {require HTTP::Request},
1256                         sub {require URI::URL},
1257                        ],
1258                 'Net::FTP' => [
1259                              sub {require Net::FTP},
1260                              sub {require Net::Config},
1261                             ],
1262                 'File::HomeDir' => [
1263                                     sub {require File::HomeDir;
1264                                          unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1265                                              for ("Will not use File::HomeDir, need 0.52\n") {
1266                                                  $CPAN::Frontend->mywarn($_);
1267                                                  die $_;
1268                                              }
1269                                          }
1270                                      },
1271                                    ],
1272                 'Archive::Tar' => [
1273                                    sub {require Archive::Tar;
1274                                         unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1275                                              for ("Will not use Archive::Tar, need 1.00\n") {
1276                                                  $CPAN::Frontend->mywarn($_);
1277                                                  die $_;
1278                                              }
1279                                         }
1280                                    },
1281                                   ],
1282                 'File::Temp' => [
1283                                  # XXX we should probably delete from
1284                                  # %INC too so we can load after we
1285                                  # installed a new enough version --
1286                                  # I'm not sure.
1287                                  sub {require File::Temp;
1288                                       unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1289                                           for ("Will not use File::Temp, need 0.16\n") {
1290                                                  $CPAN::Frontend->mywarn($_);
1291                                                  die $_;
1292                                           }
1293                                       }
1294                                  },
1295                                 ]
1296                };
1297      if ($usable->{$mod}) {
1298          for my $c (0..$#{$usable->{$mod}}) {
1299              my $code = $usable->{$mod}[$c];
1300              my $ret = eval { &$code() };
1301              $ret = "" unless defined $ret;
1302              if ($@) {
1303                  # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1304                  return;
1305              }
1306          }
1307      }
1308      return $HAS_USABLE->{$mod} = 1;
1309  }
1310  
1311  #-> sub CPAN::has_inst
1312  sub has_inst {
1313      my($self,$mod,$message) = @_;
1314      Carp::croak("CPAN->has_inst() called without an argument")
1315          unless defined $mod;
1316      my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1317          keys %{$CPAN::Config->{dontload_hash}||{}},
1318              @{$CPAN::Config->{dontload_list}||[]};
1319      if (defined $message && $message eq "no"  # afair only used by Nox
1320          ||
1321          $dont{$mod}
1322         ) {
1323        $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1324        return 0;
1325      }
1326      my $file = $mod;
1327      my $obj;
1328      $file =~ s|::|/|g;
1329      $file .= ".pm";
1330      if ($INC{$file}) {
1331          # checking %INC is wrong, because $INC{LWP} may be true
1332          # although $INC{"URI/URL.pm"} may have failed. But as
1333          # I really want to say "bla loaded OK", I have to somehow
1334          # cache results.
1335          ### warn "$file in %INC"; #debug
1336          return 1;
1337      } elsif (eval { require $file }) {
1338          # eval is good: if we haven't yet read the database it's
1339          # perfect and if we have installed the module in the meantime,
1340          # it tries again. The second require is only a NOOP returning
1341          # 1 if we had success, otherwise it's retrying
1342  
1343          my $mtime = (stat $INC{$file})[9];
1344          # privileged files loaded by has_inst; Note: we use $mtime
1345          # as a proxy for a checksum.
1346          $CPAN::Shell::reload->{$file} = $mtime;
1347          my $v = eval "\$$mod\::VERSION";
1348          $v = $v ? " (v$v)" : "";
1349          CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1350          if ($mod eq "CPAN::WAIT") {
1351              push @CPAN::Shell::ISA, 'CPAN::WAIT';
1352          }
1353          return 1;
1354      } elsif ($mod eq "Net::FTP") {
1355          $CPAN::Frontend->mywarn(qq{
1356    Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1357    if you just type
1358        install Bundle::libnet
1359  
1360  }) unless $Have_warned->{"Net::FTP"}++;
1361          $CPAN::Frontend->mysleep(3);
1362      } elsif ($mod eq "Digest::SHA") {
1363          if ($Have_warned->{"Digest::SHA"}++) {
1364              $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1365                                       qq{because Digest::SHA not installed.\n});
1366          } else {
1367              $CPAN::Frontend->mywarn(qq{
1368    CPAN: checksum security checks disabled because Digest::SHA not installed.
1369    Please consider installing the Digest::SHA module.
1370  
1371  });
1372              $CPAN::Frontend->mysleep(2);
1373          }
1374      } elsif ($mod eq "Module::Signature") {
1375          # NOT prefs_lookup, we are not a distro
1376          my $check_sigs = $CPAN::Config->{check_sigs};
1377          if (not $check_sigs) {
1378              # they do not want us:-(
1379          } elsif (not $Have_warned->{"Module::Signature"}++) {
1380              # No point in complaining unless the user can
1381              # reasonably install and use it.
1382              if (eval { require Crypt::OpenPGP; 1 } ||
1383                  (
1384                   defined $CPAN::Config->{'gpg'}
1385                   &&
1386                   $CPAN::Config->{'gpg'} =~ /\S/
1387                  )
1388                 ) {
1389                  $CPAN::Frontend->mywarn(qq{
1390    CPAN: Module::Signature security checks disabled because Module::Signature
1391    not installed.  Please consider installing the Module::Signature module.
1392    You may also need to be able to connect over the Internet to the public
1393    keyservers like pgp.mit.edu (port 11371).
1394  
1395  });
1396                  $CPAN::Frontend->mysleep(2);
1397              }
1398          }
1399      } else {
1400          delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1401      }
1402      return 0;
1403  }
1404  
1405  #-> sub CPAN::instance ;
1406  sub instance {
1407      my($mgr,$class,$id) = @_;
1408      CPAN::Index->reload;
1409      $id ||= "";
1410      # unsafe meta access, ok?
1411      return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1412      $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1413  }
1414  
1415  #-> sub CPAN::new ;
1416  sub new {
1417      bless {}, shift;
1418  }
1419  
1420  #-> sub CPAN::cleanup ;
1421  sub cleanup {
1422    # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1423    local $SIG{__DIE__} = '';
1424    my($message) = @_;
1425    my $i = 0;
1426    my $ineval = 0;
1427    my($subroutine);
1428    while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1429        $ineval = 1, last if
1430          $subroutine eq '(eval)';
1431    }
1432    return if $ineval && !$CPAN::End;
1433    return unless defined $META->{LOCK};
1434    return unless -f $META->{LOCK};
1435    $META->savehist;
1436    close $META->{LOCKFH};
1437    unlink $META->{LOCK};
1438    # require Carp;
1439    # Carp::cluck("DEBUGGING");
1440    if ( $CPAN::CONFIG_DIRTY ) {
1441        $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1442    }
1443    $CPAN::Frontend->myprint("Lockfile removed.\n");
1444  }
1445  
1446  #-> sub CPAN::readhist
1447  sub readhist {
1448      my($self,$term,$histfile) = @_;
1449      my($fh) = FileHandle->new;
1450      open $fh, "<$histfile" or last;
1451      local $/ = "\n";
1452      while (<$fh>) {
1453          chomp;
1454          $term->AddHistory($_);
1455      }
1456      close $fh;
1457  }
1458  
1459  #-> sub CPAN::savehist
1460  sub savehist {
1461      my($self) = @_;
1462      my($histfile,$histsize);
1463      unless ($histfile = $CPAN::Config->{'histfile'}) {
1464          $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1465          return;
1466      }
1467      $histsize = $CPAN::Config->{'histsize'} || 100;
1468      if ($CPAN::term) {
1469          unless ($CPAN::term->can("GetHistory")) {
1470              $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1471              return;
1472          }
1473      } else {
1474          return;
1475      }
1476      my @h = $CPAN::term->GetHistory;
1477      splice @h, 0, @h-$histsize if @h>$histsize;
1478      my($fh) = FileHandle->new;
1479      open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1480      local $\ = local $, = "\n";
1481      print $fh @h;
1482      close $fh;
1483  }
1484  
1485  #-> sub CPAN::is_tested
1486  sub is_tested {
1487      my($self,$what,$when) = @_;
1488      unless ($what) {
1489          Carp::cluck("DEBUG: empty what");
1490          return;
1491      }
1492      $self->{is_tested}{$what} = $when;
1493  }
1494  
1495  #-> sub CPAN::is_installed
1496  # unsets the is_tested flag: as soon as the thing is installed, it is
1497  # not needed in set_perl5lib anymore
1498  sub is_installed {
1499      my($self,$what) = @_;
1500      delete $self->{is_tested}{$what};
1501  }
1502  
1503  sub _list_sorted_descending_is_tested {
1504      my($self) = @_;
1505      sort
1506          { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1507              keys %{$self->{is_tested}}
1508  }
1509  
1510  #-> sub CPAN::set_perl5lib
1511  sub set_perl5lib {
1512      my($self,$for) = @_;
1513      unless ($for) {
1514          (undef,undef,undef,$for) = caller(1);
1515          $for =~ s/.*://;
1516      }
1517      $self->{is_tested} ||= {};
1518      return unless %{$self->{is_tested}};
1519      my $env = $ENV{PERL5LIB};
1520      $env = $ENV{PERLLIB} unless defined $env;
1521      my @env;
1522      push @env, $env if defined $env and length $env;
1523      #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1524      #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1525  
1526      my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1527      if (@dirs < 12) {
1528          $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1529      } elsif (@dirs < 24) {
1530          my @d = map {my $cp = $_;
1531                       $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1532                       $cp
1533                   } @dirs;
1534          $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1535                                   "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1536                                   "for '$for'\n"
1537                                  );
1538      } else {
1539          my $cnt = keys %{$self->{is_tested}};
1540          $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1541                                   "$cnt build dirs to PERL5LIB; ".
1542                                   "for '$for'\n"
1543                                  );
1544      }
1545  
1546      $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1547  }
1548  
1549  package CPAN::CacheMgr;
1550  use strict;
1551  
1552  #-> sub CPAN::CacheMgr::as_string ;
1553  sub as_string {
1554      eval { require Data::Dumper };
1555      if ($@) {
1556          return shift->SUPER::as_string;
1557      } else {
1558          return Data::Dumper::Dumper(shift);
1559      }
1560  }
1561  
1562  #-> sub CPAN::CacheMgr::cachesize ;
1563  sub cachesize {
1564      shift->{DU};
1565  }
1566  
1567  #-> sub CPAN::CacheMgr::tidyup ;
1568  sub tidyup {
1569    my($self) = @_;
1570    return unless $CPAN::META->{LOCK};
1571    return unless -d $self->{ID};
1572    my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1573    for my $current (0..$#toremove) {
1574      my $toremove = $toremove[$current];
1575      $CPAN::Frontend->myprint(sprintf(
1576                                       "DEL(%d/%d): %s \n",
1577                                       $current+1,
1578                                       scalar @toremove,
1579                                       $toremove,
1580                                      )
1581                              );
1582      return if $CPAN::Signal;
1583      $self->_clean_cache($toremove);
1584      return if $CPAN::Signal;
1585    }
1586  }
1587  
1588  #-> sub CPAN::CacheMgr::dir ;
1589  sub dir {
1590      shift->{ID};
1591  }
1592  
1593  #-> sub CPAN::CacheMgr::entries ;
1594  sub entries {
1595      my($self,$dir) = @_;
1596      return unless defined $dir;
1597      $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1598      $dir ||= $self->{ID};
1599      my($cwd) = CPAN::anycwd();
1600      chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1601      my $dh = DirHandle->new(File::Spec->curdir)
1602          or Carp::croak("Couldn't opendir $dir: $!");
1603      my(@entries);
1604      for ($dh->read) {
1605          next if $_ eq "." || $_ eq "..";
1606          if (-f $_) {
1607              push @entries, File::Spec->catfile($dir,$_);
1608          } elsif (-d _) {
1609              push @entries, File::Spec->catdir($dir,$_);
1610          } else {
1611              $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1612          }
1613      }
1614      chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1615      sort { -M $a <=> -M $b} @entries;
1616  }
1617  
1618  #-> sub CPAN::CacheMgr::disk_usage ;
1619  sub disk_usage {
1620      my($self,$dir,$fast) = @_;
1621      return if exists $self->{SIZE}{$dir};
1622      return if $CPAN::Signal;
1623      my($Du) = 0;
1624      if (-e $dir) {
1625          if (-d $dir) {
1626              unless (-x $dir) {
1627                  unless (chmod 0755, $dir) {
1628                      $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1629                                              "permission to change the permission; cannot ".
1630                                              "estimate disk usage of '$dir'\n");
1631                      $CPAN::Frontend->mysleep(5);
1632                      return;
1633                  }
1634              }
1635          } elsif (-f $dir) {
1636              # nothing to say, no matter what the permissions
1637          }
1638      } else {
1639          $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1640          return;
1641      }
1642      if ($fast) {
1643          $Du = 0; # placeholder
1644      } else {
1645          find(
1646               sub {
1647             $File::Find::prune++ if $CPAN::Signal;
1648             return if -l $_;
1649             if ($^O eq 'MacOS') {
1650               require Mac::Files;
1651               my $cat  = Mac::Files::FSpGetCatInfo($_);
1652               $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1653             } else {
1654               if (-d _) {
1655                 unless (-x _) {
1656                   unless (chmod 0755, $_) {
1657                     $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1658                                             "the permission to change the permission; ".
1659                                             "can only partially estimate disk usage ".
1660                                             "of '$_'\n");
1661                     $CPAN::Frontend->mysleep(5);
1662                     return;
1663                   }
1664                 }
1665               } else {
1666                 $Du += (-s _);
1667               }
1668             }
1669           },
1670           $dir
1671              );
1672      }
1673      return if $CPAN::Signal;
1674      $self->{SIZE}{$dir} = $Du/1024/1024;
1675      unshift @{$self->{FIFO}}, $dir;
1676      $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1677      $self->{DU} += $Du/1024/1024;
1678      $self->{DU};
1679  }
1680  
1681  #-> sub CPAN::CacheMgr::_clean_cache ;
1682  sub _clean_cache {
1683      my($self,$dir) = @_;
1684      return unless -e $dir;
1685      unless (File::Spec->canonpath(File::Basename::dirname($dir))
1686              eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1687          $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1688                                  "will not remove\n");
1689          $CPAN::Frontend->mysleep(5);
1690          return;
1691      }
1692      $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1693          if $CPAN::DEBUG;
1694      File::Path::rmtree($dir);
1695      my $id_deleted = 0;
1696      if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1697          my $yaml_module = CPAN::_yaml_module;
1698          if ($CPAN::META->has_inst($yaml_module)) {
1699              my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1700              if ($@) {
1701                  $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1702                  unlink "$dir.yml" or
1703                      $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1704                  return;
1705              } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1706                  $CPAN::META->delete("CPAN::Distribution", $id);
1707  
1708                  # XXX we should restore the state NOW, otherise this
1709                  # distro does not exist until we read an index. BUG ALERT(?)
1710  
1711                  # $CPAN::Frontend->mywarn (" +++\n");
1712                  $id_deleted++;
1713              }
1714          }
1715          unlink "$dir.yml"; # may fail
1716          unless ($id_deleted) {
1717              CPAN->debug("no distro found associated with '$dir'");
1718          }
1719      }
1720      $self->{DU} -= $self->{SIZE}{$dir};
1721      delete $self->{SIZE}{$dir};
1722  }
1723  
1724  #-> sub CPAN::CacheMgr::new ;
1725  sub new {
1726      my $class = shift;
1727      my $time = time;
1728      my($debug,$t2);
1729      $debug = "";
1730      my $self = {
1731          ID => $CPAN::Config->{build_dir},
1732          MAX => $CPAN::Config->{'build_cache'},
1733          SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1734          DU => 0
1735      };
1736      File::Path::mkpath($self->{ID});
1737      my $dh = DirHandle->new($self->{ID});
1738      bless $self, $class;
1739      $self->scan_cache;
1740      $t2 = time;
1741      $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1742      $time = $t2;
1743      CPAN->debug($debug) if $CPAN::DEBUG;
1744      $self;
1745  }
1746  
1747  #-> sub CPAN::CacheMgr::scan_cache ;
1748  sub scan_cache {
1749      my $self = shift;
1750      return if $self->{SCAN} eq 'never';
1751      $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1752          unless $self->{SCAN} eq 'atstart';
1753      return unless $CPAN::META->{LOCK};
1754      $CPAN::Frontend->myprint(
1755                               sprintf("Scanning cache %s for sizes\n",
1756                               $self->{ID}));
1757      my $e;
1758      my @entries = $self->entries($self->{ID});
1759      my $i = 0;
1760      my $painted = 0;
1761      for $e (@entries) {
1762          my $symbol = ".";
1763          if ($self->{DU} > $self->{MAX}) {
1764              $symbol = "-";
1765              $self->disk_usage($e,1);
1766          } else {
1767              $self->disk_usage($e);
1768          }
1769          $i++;
1770          while (($painted/76) < ($i/@entries)) {
1771              $CPAN::Frontend->myprint($symbol);
1772              $painted++;
1773          }
1774          return if $CPAN::Signal;
1775      }
1776      $CPAN::Frontend->myprint("DONE\n");
1777      $self->tidyup;
1778  }
1779  
1780  package CPAN::Shell;
1781  use strict;
1782  
1783  #-> sub CPAN::Shell::h ;
1784  sub h {
1785      my($class,$about) = @_;
1786      if (defined $about) {
1787          my $help;
1788          if (exists $Help->{$about}) {
1789              if (ref $Help->{$about}) { # aliases
1790                  $about = ${$Help->{$about}};
1791              }
1792              $help = $Help->{$about};
1793          } else {
1794              $help = "No help available";
1795          }
1796          $CPAN::Frontend->myprint("$about\: $help\n");
1797      } else {
1798          my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1799          $CPAN::Frontend->myprint(qq{
1800  Display Information $filler (ver $CPAN::VERSION)
1801   command  argument          description
1802   a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1803   i        WORD or /REGEXP/  about any of the above
1804   ls       AUTHOR or GLOB    about files in the author's directory
1805      (with WORD being a module, bundle or author name or a distribution
1806      name of the form AUTHOR/DISTRIBUTION)
1807  
1808  Download, Test, Make, Install...
1809   get      download                     clean    make clean
1810   make     make (implies get)           look     open subshell in dist directory
1811   test     make test (implies make)     readme   display these README files
1812   install  make install (implies test)  perldoc  display POD documentation
1813  
1814  Upgrade
1815   r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1816   upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1817  
1818  Pragmas
1819   force  CMD    try hard to do command  fforce CMD    try harder
1820   notest CMD    skip testing
1821  
1822  Other
1823   h,?           display this menu       ! perl-code   eval a perl command
1824   o conf [opt]  set and query options   q             quit the cpan shell
1825   reload cpan   load CPAN.pm again      reload index  load newer indices
1826   autobundle    Snapshot                recent        latest CPAN uploads});
1827  }
1828  }
1829  
1830  *help = \&h;
1831  
1832  #-> sub CPAN::Shell::a ;
1833  sub a {
1834    my($self,@arg) = @_;
1835    # authors are always UPPERCASE
1836    for (@arg) {
1837      $_ = uc $_ unless /=/;
1838    }
1839    $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1840  }
1841  
1842  #-> sub CPAN::Shell::globls ;
1843  sub globls {
1844      my($self,$s,$pragmas) = @_;
1845      # ls is really very different, but we had it once as an ordinary
1846      # command in the Shell (upto rev. 321) and we could not handle
1847      # force well then
1848      my(@accept,@preexpand);
1849      if ($s =~ /[\*\?\/]/) {
1850          if ($CPAN::META->has_inst("Text::Glob")) {
1851              if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1852                  my $rau = Text::Glob::glob_to_regex(uc $au);
1853                  CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1854                        if $CPAN::DEBUG;
1855                  push @preexpand, map { $_->id . "/" . $pathglob }
1856                      CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1857              } else {
1858                  my $rau = Text::Glob::glob_to_regex(uc $s);
1859                  push @preexpand, map { $_->id }
1860                      CPAN::Shell->expand_by_method('CPAN::Author',
1861                                                    ['id'],
1862                                                    "/$rau/");
1863              }
1864          } else {
1865              $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1866          }
1867      } else {
1868          push @preexpand, uc $s;
1869      }
1870      for (@preexpand) {
1871          unless (/^[A-Z0-9\-]+(\/|$)/i) {
1872              $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1873              next;
1874          }
1875          push @accept, $_;
1876      }
1877      my $silent = @accept>1;
1878      my $last_alpha = "";
1879      my @results;
1880      for my $a (@accept) {
1881          my($author,$pathglob);
1882          if ($a =~ m|(.*?)/(.*)|) {
1883              my $a2 = $1;
1884              $pathglob = $2;
1885              $author = CPAN::Shell->expand_by_method('CPAN::Author',
1886                                                      ['id'],
1887                                                      $a2)
1888                  or $CPAN::Frontend->mydie("No author found for $a2\n");
1889          } else {
1890              $author = CPAN::Shell->expand_by_method('CPAN::Author',
1891                                                      ['id'],
1892                                                      $a)
1893                  or $CPAN::Frontend->mydie("No author found for $a\n");
1894          }
1895          if ($silent) {
1896              my $alpha = substr $author->id, 0, 1;
1897              my $ad;
1898              if ($alpha eq $last_alpha) {
1899                  $ad = "";
1900              } else {
1901                  $ad = "[$alpha]";
1902                  $last_alpha = $alpha;
1903              }
1904              $CPAN::Frontend->myprint($ad);
1905          }
1906          for my $pragma (@$pragmas) {
1907              if ($author->can($pragma)) {
1908                  $author->$pragma();
1909              }
1910          }
1911          push @results, $author->ls($pathglob,$silent); # silent if
1912                                                         # more than one
1913                                                         # author
1914          for my $pragma (@$pragmas) {
1915              my $unpragma = "un$pragma";
1916              if ($author->can($unpragma)) {
1917                  $author->$unpragma();
1918              }
1919          }
1920      }
1921      @results;
1922  }
1923  
1924  #-> sub CPAN::Shell::local_bundles ;
1925  sub local_bundles {
1926      my($self,@which) = @_;
1927      my($incdir,$bdir,$dh);
1928      foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1929          my @bbase = "Bundle";
1930          while (my $bbase = shift @bbase) {
1931              $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1932              CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1933              if ($dh = DirHandle->new($bdir)) { # may fail
1934                  my($entry);
1935                  for $entry ($dh->read) {
1936                      next if $entry =~ /^\./;
1937                      next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1938                      if (-d File::Spec->catdir($bdir,$entry)) {
1939                          push @bbase, "$bbase\::$entry";
1940                      } else {
1941                          next unless $entry =~ s/\.pm(?!\n)\Z//;
1942                          $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1943                      }
1944                  }
1945              }
1946          }
1947      }
1948  }
1949  
1950  #-> sub CPAN::Shell::b ;
1951  sub b {
1952      my($self,@which) = @_;
1953      CPAN->debug("which[@which]") if $CPAN::DEBUG;
1954      $self->local_bundles;
1955      $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1956  }
1957  
1958  #-> sub CPAN::Shell::d ;
1959  sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1960  
1961  #-> sub CPAN::Shell::m ;
1962  sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1963      my $self = shift;
1964      $CPAN::Frontend->myprint($self->format_result('Module',@_));
1965  }
1966  
1967  #-> sub CPAN::Shell::i ;
1968  sub i {
1969      my($self) = shift;
1970      my(@args) = @_;
1971      @args = '/./' unless @args;
1972      my(@result);
1973      for my $type (qw/Bundle Distribution Module/) {
1974          push @result, $self->expand($type,@args);
1975      }
1976      # Authors are always uppercase.
1977      push @result, $self->expand("Author", map { uc $_ } @args);
1978  
1979      my $result = @result == 1 ?
1980          $result[0]->as_string :
1981              @result == 0 ?
1982                  "No objects found of any type for argument @args\n" :
1983                      join("",
1984                           (map {$_->as_glimpse} @result),
1985                           scalar @result, " items found\n",
1986                          );
1987      $CPAN::Frontend->myprint($result);
1988  }
1989  
1990  #-> sub CPAN::Shell::o ;
1991  
1992  # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1993  # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1994  # probably have been called 'set' and 'o debug' maybe 'set debug' or
1995  # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1996  sub o {
1997      my($self,$o_type,@o_what) = @_;
1998      $o_type ||= "";
1999      CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2000      if ($o_type eq 'conf') {
2001          my($cfilter);
2002          ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2003          if (!@o_what or $cfilter) { # print all things, "o conf"
2004              $cfilter ||= "";
2005              my $qrfilter = eval 'qr/$cfilter/';
2006              my($k,$v);
2007              $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2008              my @from;
2009              if (exists $INC{'CPAN/Config.pm'}) {
2010                  push @from, $INC{'CPAN/Config.pm'};
2011              }
2012              if (exists $INC{'CPAN/MyConfig.pm'}) {
2013                  push @from, $INC{'CPAN/MyConfig.pm'};
2014              }
2015              $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2016              $CPAN::Frontend->myprint(":\n");
2017              for $k (sort keys %CPAN::HandleConfig::can) {
2018                  next unless $k =~ /$qrfilter/;
2019                  $v = $CPAN::HandleConfig::can{$k};
2020                  $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2021              }
2022              $CPAN::Frontend->myprint("\n");
2023              for $k (sort keys %CPAN::HandleConfig::keys) {
2024                  next unless $k =~ /$qrfilter/;
2025                  CPAN::HandleConfig->prettyprint($k);
2026              }
2027              $CPAN::Frontend->myprint("\n");
2028          } else {
2029              if (CPAN::HandleConfig->edit(@o_what)) {
2030              } else {
2031                  $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2032                                           qq{items\n\n});
2033              }
2034          }
2035      } elsif ($o_type eq 'debug') {
2036          my(%valid);
2037          @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2038          if (@o_what) {
2039              while (@o_what) {
2040                  my($what) = shift @o_what;
2041                  if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2042                      $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2043                      next;
2044                  }
2045                  if ( exists $CPAN::DEBUG{$what} ) {
2046                      $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2047                  } elsif ($what =~ /^\d/) {
2048                      $CPAN::DEBUG = $what;
2049                  } elsif (lc $what eq 'all') {
2050                      my($max) = 0;
2051                      for (values %CPAN::DEBUG) {
2052                          $max += $_;
2053                      }
2054                      $CPAN::DEBUG = $max;
2055                  } else {
2056                      my($known) = 0;
2057                      for (keys %CPAN::DEBUG) {
2058                          next unless lc($_) eq lc($what);
2059                          $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2060                          $known = 1;
2061                      }
2062                      $CPAN::Frontend->myprint("unknown argument [$what]\n")
2063                          unless $known;
2064                  }
2065              }
2066          } else {
2067              my $raw = "Valid options for debug are ".
2068                  join(", ",sort(keys %CPAN::DEBUG), 'all').
2069                       qq{ or a number. Completion works on the options. }.
2070                       qq{Case is ignored.};
2071              require Text::Wrap;
2072              $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2073              $CPAN::Frontend->myprint("\n\n");
2074          }
2075          if ($CPAN::DEBUG) {
2076              $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2077              my($k,$v);
2078              for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2079                  $v = $CPAN::DEBUG{$k};
2080                  $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2081                      if $v & $CPAN::DEBUG;
2082              }
2083          } else {
2084              $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2085          }
2086      } else {
2087          $CPAN::Frontend->myprint(qq{
2088  Known options:
2089    conf    set or get configuration variables
2090    debug   set or get debugging options
2091  });
2092      }
2093  }
2094  
2095  # CPAN::Shell::paintdots_onreload
2096  sub paintdots_onreload {
2097      my($ref) = shift;
2098      sub {
2099          if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2100              my($subr) = $1;
2101              ++$$ref;
2102              local($|) = 1;
2103              # $CPAN::Frontend->myprint(".($subr)");
2104              $CPAN::Frontend->myprint(".");
2105              if ($subr =~ /\bshell\b/i) {
2106                  # warn "debug[$_[0]]";
2107  
2108                  # It would be nice if we could detect that a
2109                  # subroutine has actually changed, but for now we
2110                  # practically always set the GOTOSHELL global
2111  
2112                  $CPAN::GOTOSHELL=1;
2113              }
2114              return;
2115          }
2116          warn @_;
2117      };
2118  }
2119  
2120  #-> sub CPAN::Shell::hosts ;
2121  sub hosts {
2122      my($self) = @_;
2123      my $fullstats = CPAN::FTP->_ftp_statistics();
2124      my $history = $fullstats->{history} || [];
2125      my %S; # statistics
2126      while (my $last = pop @$history) {
2127          my $attempts = $last->{attempts} or next;
2128          my $start;
2129          if (@$attempts) {
2130              $start = $attempts->[-1]{start};
2131              if ($#$attempts > 0) {
2132                  for my $i (0..$#$attempts-1) {
2133                      my $url = $attempts->[$i]{url} or next;
2134                      $S{no}{$url}++;
2135                  }
2136              }
2137          } else {
2138              $start = $last->{start};
2139          }
2140          next unless $last->{thesiteurl}; # C-C? bad filenames?
2141          $S{start} = $start;
2142          $S{end} ||= $last->{end};
2143          my $dltime = $last->{end} - $start;
2144          my $dlsize = $last->{filesize} || 0;
2145          my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2146          my $s = $S{ok}{$url} ||= {};
2147          $s->{n}++;
2148          $s->{dlsize} ||= 0;
2149          $s->{dlsize} += $dlsize/1024;
2150          $s->{dltime} ||= 0;
2151          $s->{dltime} += $dltime;
2152      }
2153      my $res;
2154      for my $url (keys %{$S{ok}}) {
2155          next if $S{ok}{$url}{dltime} == 0; # div by zero
2156          push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2157                               $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2158                               $url,
2159                              ];
2160      }
2161      for my $url (keys %{$S{no}}) {
2162          push @{$res->{no}}, [$S{no}{$url},
2163                               $url,
2164                              ];
2165      }
2166      my $R = ""; # report
2167      if ($S{start} && $S{end}) {
2168          $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2169          $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2170      }
2171      if ($res->{ok} && @{$res->{ok}}) {
2172          $R .= sprintf "\nSuccessful downloads:
2173     N       kB  secs      kB/s url\n";
2174          my $i = 20;
2175          for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2176              $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2177              last if --$i<=0;
2178          }
2179      }
2180      if ($res->{no} && @{$res->{no}}) {
2181          $R .= sprintf "\nUnsuccessful downloads:\n";
2182          my $i = 20;
2183          for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2184              $R .= sprintf "%4d %s\n", @$_;
2185              last if --$i<=0;
2186          }
2187      }
2188      $CPAN::Frontend->myprint($R);
2189  }
2190  
2191  #-> sub CPAN::Shell::reload ;
2192  sub reload {
2193      my($self,$command,@arg) = @_;
2194      $command ||= "";
2195      $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2196      if ($command =~ /^cpan$/i) {
2197          my $redef = 0;
2198          chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2199          my $failed;
2200          my @relo = (
2201                      "CPAN.pm",
2202                      "CPAN/Debug.pm",
2203                      "CPAN/FirstTime.pm",
2204                      "CPAN/HandleConfig.pm",
2205                      "CPAN/Kwalify.pm",
2206                      "CPAN/Queue.pm",
2207                      "CPAN/Reporter/Config.pm",
2208                      "CPAN/Reporter/History.pm",
2209                      "CPAN/Reporter.pm",
2210                      "CPAN/SQLite.pm",
2211                      "CPAN/Tarzip.pm",
2212                      "CPAN/Version.pm",
2213                     );
2214        MFILE: for my $f (@relo) {
2215              next unless exists $INC{$f};
2216              my $p = $f;
2217              $p =~ s/\.pm$//;
2218              $p =~ s|/|::|g;
2219              $CPAN::Frontend->myprint("($p");
2220              local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2221              $self->_reload_this($f) or $failed++;
2222              my $v = eval "$p\::->VERSION";
2223              $CPAN::Frontend->myprint("v$v)");
2224          }
2225          $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2226          if ($failed) {
2227              my $errors = $failed == 1 ? "error" : "errors";
2228              $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2229                                      "this session.\n");
2230          }
2231      } elsif ($command =~ /^index$/i) {
2232        CPAN::Index->force_reload;
2233      } else {
2234        $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2235  index    re-reads the index files\n});
2236      }
2237  }
2238  
2239  # reload means only load again what we have loaded before
2240  #-> sub CPAN::Shell::_reload_this ;
2241  sub _reload_this {
2242      my($self,$f,$args) = @_;
2243      CPAN->debug("f[$f]") if $CPAN::DEBUG;
2244      return 1 unless $INC{$f}; # we never loaded this, so we do not
2245                                # reload but say OK
2246      my $pwd = CPAN::anycwd();
2247      CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2248      my($file);
2249      for my $inc (@INC) {
2250          $file = File::Spec->catfile($inc,split /\//, $f);
2251          last if -f $file;
2252          $file = "";
2253      }
2254      CPAN->debug("file[$file]") if $CPAN::DEBUG;
2255      my @inc = @INC;
2256      unless ($file && -f $file) {
2257          # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2258          $file = $INC{$f};
2259          unless (CPAN->has_inst("File::Basename")) {
2260              @inc = File::Basename::dirname($file);
2261          } else {
2262              # do we ever need this?
2263              @inc = substr($file,0,-length($f)-1); # bring in back to me!
2264          }
2265      }
2266      CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2267      unless (-f $file) {
2268          $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2269          return;
2270      }
2271      my $mtime = (stat $file)[9];
2272      if ($reload->{$f}) {
2273      } elsif ($^T < $mtime) {
2274          # since we started the file has changed, force it to be reloaded
2275          $reload->{$f} = -1;
2276      } else {
2277          $reload->{$f} = $mtime;
2278      }
2279      my $must_reload = $mtime != $reload->{$f};
2280      $args ||= {};
2281      $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2282      if ($must_reload) {
2283          my $fh = FileHandle->new($file) or
2284              $CPAN::Frontend->mydie("Could not open $file: $!");
2285          local($/);
2286          local $^W = 1;
2287          my $content = <$fh>;
2288          CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2289              if $CPAN::DEBUG;
2290          delete $INC{$f};
2291          local @INC = @inc;
2292          eval "require '$f'";
2293          if ($@) {
2294              warn $@;
2295              return;
2296          }
2297          $reload->{$f} = $mtime;
2298      } else {
2299          $CPAN::Frontend->myprint("__unchanged__");
2300      }
2301      return 1;
2302  }
2303  
2304  #-> sub CPAN::Shell::mkmyconfig ;
2305  sub mkmyconfig {
2306      my($self, $cpanpm, %args) = @_;
2307      require CPAN::FirstTime;
2308      my $home = CPAN::HandleConfig::home;
2309      $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2310          File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2311      File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2312      CPAN::HandleConfig::require_myconfig_or_config;
2313      $CPAN::Config ||= {};
2314      $CPAN::Config = {
2315          %$CPAN::Config,
2316          build_dir           =>  undef,
2317          cpan_home           =>  undef,
2318          keep_source_where   =>  undef,
2319          histfile            =>  undef,
2320      };
2321      CPAN::FirstTime::init($cpanpm, %args);
2322  }
2323  
2324  #-> sub CPAN::Shell::_binary_extensions ;
2325  sub _binary_extensions {
2326      my($self) = shift @_;
2327      my(@result,$module,%seen,%need,$headerdone);
2328      for $module ($self->expand('Module','/./')) {
2329          my $file  = $module->cpan_file;
2330          next if $file eq "N/A";
2331          next if $file =~ /^Contact Author/;
2332          my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2333          next if $dist->isa_perl;
2334          next unless $module->xs_file;
2335          local($|) = 1;
2336          $CPAN::Frontend->myprint(".");
2337          push @result, $module;
2338      }
2339  #    print join " | ", @result;
2340      $CPAN::Frontend->myprint("\n");
2341      return @result;
2342  }
2343  
2344  #-> sub CPAN::Shell::recompile ;
2345  sub recompile {
2346      my($self) = shift @_;
2347      my($module,@module,$cpan_file,%dist);
2348      @module = $self->_binary_extensions();
2349      for $module (@module) { # we force now and compile later, so we
2350                              # don't do it twice
2351          $cpan_file = $module->cpan_file;
2352          my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2353          $pack->force;
2354          $dist{$cpan_file}++;
2355      }
2356      for $cpan_file (sort keys %dist) {
2357          $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2358          my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2359          $pack->install;
2360          $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2361                             # stop a package from recompiling,
2362                             # e.g. IO-1.12 when we have perl5.003_10
2363      }
2364  }
2365  
2366  #-> sub CPAN::Shell::scripts ;
2367  sub scripts {
2368      my($self, $arg) = @_;
2369      $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2370  
2371      for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2372          unless ($CPAN::META->has_inst($req)) {
2373              $CPAN::Frontend->mywarn("  $req not available\n");
2374          }
2375      }
2376      my $p = HTML::LinkExtor->new();
2377      my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2378      unless (-f $indexfile) {
2379          $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2380      }
2381      $p->parse_file($indexfile);
2382      my @hrefs;
2383      my $qrarg;
2384      if ($arg =~ s|^/(.+)/$|$1|) {
2385          $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2386      }
2387      for my $l ($p->links) {
2388          my $tag = shift @$l;
2389          next unless $tag eq "a";
2390          my %att = @$l;
2391          my $href = $att{href};
2392          next unless $href =~ s|^\.\./authors/id/./../||;
2393          if ($arg) {
2394              if ($qrarg) {
2395                  if ($href =~ $qrarg) {
2396                      push @hrefs, $href;
2397                  }
2398              } else {
2399                  if ($href =~ /\Q$arg\E/) {
2400                      push @hrefs, $href;
2401                  }
2402              }
2403          } else {
2404              push @hrefs, $href;
2405          }
2406      }
2407      # now filter for the latest version if there is more than one of a name
2408      my %stems;
2409      for (sort @hrefs) {
2410          my $href = $_;
2411          s/-v?\d.*//;
2412          my $stem = $_;
2413          $stems{$stem} ||= [];
2414          push @{$stems{$stem}}, $href;
2415      }
2416      for (sort keys %stems) {
2417          my $highest;
2418          if (@{$stems{$_}} > 1) {
2419              $highest = List::Util::reduce {
2420                  Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2421                } @{$stems{$_}};
2422          } else {
2423              $highest = $stems{$_}[0];
2424          }
2425          $CPAN::Frontend->myprint("$highest\n");
2426      }
2427  }
2428  
2429  #-> sub CPAN::Shell::report ;
2430  sub report {
2431      my($self,@args) = @_;
2432      unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2433          $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2434      }
2435      local $CPAN::Config->{test_report} = 1;
2436      $self->force("test",@args); # force is there so that the test be
2437                                  # re-run (as documented)
2438  }
2439  
2440  # compare with is_tested
2441  #-> sub CPAN::Shell::install_tested
2442  sub install_tested {
2443      my($self,@some) = @_;
2444      $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2445          return if @some;
2446      CPAN::Index->reload;
2447  
2448      for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2449          my $yaml = "$b.yml";
2450          unless (-f $yaml) {
2451              $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2452              next;
2453          }
2454          my $yaml_content = CPAN->_yaml_loadfile($yaml);
2455          my $id = $yaml_content->[0]{distribution}{ID};
2456          unless ($id) {
2457              $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2458              next;
2459          }
2460          my $do = CPAN::Shell->expandany($id);
2461          unless ($do) {
2462              $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2463              next;
2464          }
2465          unless ($do->{build_dir}) {
2466              $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2467              next;
2468          }
2469          unless ($do->{build_dir} eq $b) {
2470              $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2471              next;
2472          }
2473          push @some, $do;
2474      }
2475  
2476      $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2477          return unless @some;
2478  
2479      @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2480      $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2481          return unless @some;
2482  
2483      # @some = grep { not $_->uptodate } @some;
2484      # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2485      #     return unless @some;
2486  
2487      CPAN->debug("some[@some]");
2488      for my $d (@some) {
2489          my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2490          $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2491          $CPAN::Frontend->mysleep(1);
2492          $self->install($d);
2493      }
2494  }
2495  
2496  #-> sub CPAN::Shell::upgrade ;
2497  sub upgrade {
2498      my($self,@args) = @_;
2499      $self->install($self->r(@args));
2500  }
2501  
2502  #-> sub CPAN::Shell::_u_r_common ;
2503  sub _u_r_common {
2504      my($self) = shift @_;
2505      my($what) = shift @_;
2506      CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2507      Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2508            $what && $what =~ /^[aru]$/;
2509      my(@args) = @_;
2510      @args = '/./' unless @args;
2511      my(@result,$module,%seen,%need,$headerdone,
2512         $version_undefs,$version_zeroes,
2513         @version_undefs,@version_zeroes);
2514      $version_undefs = $version_zeroes = 0;
2515      my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2516      my @expand = $self->expand('Module',@args);
2517      my $expand = scalar @expand;
2518      if (0) { # Looks like noise to me, was very useful for debugging
2519               # for metadata cache
2520          $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2521      }
2522    MODULE: for $module (@expand) {
2523          my $file  = $module->cpan_file;
2524          next MODULE unless defined $file; # ??
2525          $file =~ s!^./../!!;
2526          my($latest) = $module->cpan_version;
2527          my($inst_file) = $module->inst_file;
2528          my($have);
2529          return if $CPAN::Signal;
2530          if ($inst_file) {
2531              if ($what eq "a") {
2532                  $have = $module->inst_version;
2533              } elsif ($what eq "r") {
2534                  $have = $module->inst_version;
2535                  local($^W) = 0;
2536                  if ($have eq "undef") {
2537                      $version_undefs++;
2538                      push @version_undefs, $module->as_glimpse;
2539                  } elsif (CPAN::Version->vcmp($have,0)==0) {
2540                      $version_zeroes++;
2541                      push @version_zeroes, $module->as_glimpse;
2542                  }
2543                  next MODULE unless CPAN::Version->vgt($latest, $have);
2544  # to be pedantic we should probably say:
2545  #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2546  # to catch the case where CPAN has a version 0 and we have a version undef
2547              } elsif ($what eq "u") {
2548                  next MODULE;
2549              }
2550          } else {
2551              if ($what eq "a") {
2552                  next MODULE;
2553              } elsif ($what eq "r") {
2554                  next MODULE;
2555              } elsif ($what eq "u") {
2556                  $have = "-";
2557              }
2558          }
2559          return if $CPAN::Signal; # this is sometimes lengthy
2560          $seen{$file} ||= 0;
2561          if ($what eq "a") {
2562              push @result, sprintf "%s %s\n", $module->id, $have;
2563          } elsif ($what eq "r") {
2564              push @result, $module->id;
2565              next MODULE if $seen{$file}++;
2566          } elsif ($what eq "u") {
2567              push @result, $module->id;
2568              next MODULE if $seen{$file}++;
2569              next MODULE if $file =~ /^Contact/;
2570          }
2571          unless ($headerdone++) {
2572              $CPAN::Frontend->myprint("\n");
2573              $CPAN::Frontend->myprint(sprintf(
2574                                               $sprintf,
2575                                               "",
2576                                               "Package namespace",
2577                                               "",
2578                                               "installed",
2579                                               "latest",
2580                                               "in CPAN file"
2581                                              ));
2582          }
2583          my $color_on = "";
2584          my $color_off = "";
2585          if (
2586              $COLOR_REGISTERED
2587              &&
2588              $CPAN::META->has_inst("Term::ANSIColor")
2589              &&
2590              $module->description
2591             ) {
2592              $color_on = Term::ANSIColor::color("green");
2593              $color_off = Term::ANSIColor::color("reset");
2594          }
2595          $CPAN::Frontend->myprint(sprintf $sprintf,
2596                                   $color_on,
2597                                   $module->id,
2598                                   $color_off,
2599                                   $have,
2600                                   $latest,
2601                                   $file);
2602          $need{$module->id}++;
2603      }
2604      unless (%need) {
2605          if ($what eq "u") {
2606              $CPAN::Frontend->myprint("No modules found for @args\n");
2607          } elsif ($what eq "r") {
2608              $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2609          }
2610      }
2611      if ($what eq "r") {
2612          if ($version_zeroes) {
2613              my $s_has = $version_zeroes > 1 ? "s have" : " has";
2614              $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2615                                       qq{a version number of 0\n});
2616              if ($CPAN::Config->{show_zero_versions}) {
2617                  local $" = "\t";
2618                  $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2619                  $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2620                                           qq{to hide them)\n});
2621              } else {
2622                  $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2623                                           qq{to show them)\n});
2624              }
2625          }
2626          if ($version_undefs) {
2627              my $s_has = $version_undefs > 1 ? "s have" : " has";
2628              $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2629                                       qq{parseable version number\n});
2630              if ($CPAN::Config->{show_unparsable_versions}) {
2631                  local $" = "\t";
2632                  $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2633                  $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2634                                           qq{to hide them)\n});
2635              } else {
2636                  $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2637                                           qq{to show them)\n});
2638              }
2639          }
2640      }
2641      @result;
2642  }
2643  
2644  #-> sub CPAN::Shell::r ;
2645  sub r {
2646      shift->_u_r_common("r",@_);
2647  }
2648  
2649  #-> sub CPAN::Shell::u ;
2650  sub u {
2651      shift->_u_r_common("u",@_);
2652  }
2653  
2654  #-> sub CPAN::Shell::failed ;
2655  sub failed {
2656      my($self,$only_id,$silent) = @_;
2657      my @failed;
2658    DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2659          my $failed = "";
2660        NAY: for my $nosayer ( # order matters!
2661                              "unwrapped",
2662                              "writemakefile",
2663                              "signature_verify",
2664                              "make",
2665                              "make_test",
2666                              "install",
2667                              "make_clean",
2668                             ) {
2669              next unless exists $d->{$nosayer};
2670              next unless defined $d->{$nosayer};
2671              next unless (
2672                           UNIVERSAL::can($d->{$nosayer},"failed") ?
2673                           $d->{$nosayer}->failed :
2674                           $d->{$nosayer} =~ /^NO/
2675                          );
2676              next NAY if $only_id && $only_id != (
2677                                                   UNIVERSAL::can($d->{$nosayer},"commandid")
2678                                                   ?
2679                                                   $d->{$nosayer}->commandid
2680                                                   :
2681                                                   $CPAN::CurrentCommandId
2682                                                  );
2683              $failed = $nosayer;
2684              last;
2685          }
2686          next DIST unless $failed;
2687          my $id = $d->id;
2688          $id =~ s|^./../||;
2689          #$print .= sprintf(
2690          #                  "  %-45s: %s %s\n",
2691          push @failed,
2692              (
2693               UNIVERSAL::can($d->{$failed},"failed") ?
2694               [
2695                $d->{$failed}->commandid,
2696                $id,
2697                $failed,
2698                $d->{$failed}->text,
2699                $d->{$failed}{TIME}||0,
2700               ] :
2701               [
2702                1,
2703                $id,
2704                $failed,
2705                $d->{$failed},
2706                0,
2707               ]
2708              );
2709      }
2710      my $scope;
2711      if ($only_id) {
2712          $scope = "this command";
2713      } elsif ($CPAN::Index::HAVE_REANIMATED) {
2714          $scope = "this or a previous session";
2715          # it might be nice to have a section for previous session and
2716          # a second for this
2717      } else {
2718          $scope = "this session";
2719      }
2720      if (@failed) {
2721          my $print;
2722          my $debug = 0;
2723          if ($debug) {
2724              $print = join "",
2725                  map { sprintf "%5d %-45s: %s %s\n", @$_ }
2726                      sort { $a->[0] <=> $b->[0] } @failed;
2727          } else {
2728              $print = join "",
2729                  map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2730                      sort {
2731                          $a->[0] <=> $b->[0]
2732                              ||
2733                                  $a->[4] <=> $b->[4]
2734                         } @failed;
2735          }
2736          $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2737      } elsif (!$only_id || !$silent) {
2738          $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2739      }
2740  }
2741  
2742  # XXX intentionally undocumented because completely bogus, unportable,
2743  # useless, etc.
2744  
2745  #-> sub CPAN::Shell::status ;
2746  sub status {
2747      my($self) = @_;
2748      require Devel::Size;
2749      my $ps = FileHandle->new;
2750      open $ps, "/proc/$$/status";
2751      my $vm = 0;
2752      while (<$ps>) {
2753          next unless /VmSize:\s+(\d+)/;
2754          $vm = $1;
2755          last;
2756      }
2757      $CPAN::Frontend->mywarn(sprintf(
2758                                      "%-27s %6d\n%-27s %6d\n",
2759                                      "vm",
2760                                      $vm,
2761                                      "CPAN::META",
2762                                      Devel::Size::total_size($CPAN::META)/1024,
2763                                     ));
2764      for my $k (sort keys %$CPAN::META) {
2765          next unless substr($k,0,4) eq "read";
2766          warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2767          for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2768              warn sprintf "  %-25s %6d (keys: %6d)\n",
2769                  $k2,
2770                      Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2771                            scalar keys %{$CPAN::META->{$k}{$k2}};
2772          }
2773      }
2774  }
2775  
2776  # compare with install_tested
2777  #-> sub CPAN::Shell::is_tested
2778  sub is_tested {
2779      my($self) = @_;
2780      CPAN::Index->reload;
2781      for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2782          my $time;
2783          if ($CPAN::META->{is_tested}{$b}) {
2784              $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2785          } else {
2786              $time = scalar localtime;
2787              $time =~ s/\S/?/g;
2788          }
2789          $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2790      }
2791  }
2792  
2793  #-> sub CPAN::Shell::autobundle ;
2794  sub autobundle {
2795      my($self) = shift;
2796      CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2797      my(@bundle) = $self->_u_r_common("a",@_);
2798      my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2799      File::Path::mkpath($todir);
2800      unless (-d $todir) {
2801          $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2802          return;
2803      }
2804      my($y,$m,$d) =  (localtime)[5,4,3];
2805      $y+=1900;
2806      $m++;
2807      my($c) = 0;
2808      my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2809      my($to) = File::Spec->catfile($todir,"$me.pm");
2810      while (-f $to) {
2811          $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2812          $to = File::Spec->catfile($todir,"$me.pm");
2813      }
2814      my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2815      $fh->print(
2816                 "package Bundle::$me;\n\n",
2817                 "\$VERSION = '0.01';\n\n",
2818                 "1;\n\n",
2819                 "__END__\n\n",
2820                 "=head1 NAME\n\n",
2821                 "Bundle::$me - Snapshot of installation on ",
2822                 $Config::Config{'myhostname'},
2823                 " on ",
2824                 scalar(localtime),
2825                 "\n\n=head1 SYNOPSIS\n\n",
2826                 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2827                 "=head1 CONTENTS\n\n",
2828                 join("\n", @bundle),
2829                 "\n\n=head1 CONFIGURATION\n\n",
2830                 Config->myconfig,
2831                 "\n\n=head1 AUTHOR\n\n",
2832                 "This Bundle has been generated automatically ",
2833                 "by the autobundle routine in CPAN.pm.\n",
2834                );
2835      $fh->close;
2836      $CPAN::Frontend->myprint("\nWrote bundle file
2837      $to\n\n");
2838  }
2839  
2840  #-> sub CPAN::Shell::expandany ;
2841  sub expandany {
2842      my($self,$s) = @_;
2843      CPAN->debug("s[$s]") if $CPAN::DEBUG;
2844      if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2845          $s = CPAN::Distribution->normalize($s);
2846          return $CPAN::META->instance('CPAN::Distribution',$s);
2847          # Distributions spring into existence, not expand
2848      } elsif ($s =~ m|^Bundle::|) {
2849          $self->local_bundles; # scanning so late for bundles seems
2850                                # both attractive and crumpy: always
2851                                # current state but easy to forget
2852                                # somewhere
2853          return $self->expand('Bundle',$s);
2854      } else {
2855          return $self->expand('Module',$s)
2856              if $CPAN::META->exists('CPAN::Module',$s);
2857      }
2858      return;
2859  }
2860  
2861  #-> sub CPAN::Shell::expand ;
2862  sub expand {
2863      my $self = shift;
2864      my($type,@args) = @_;
2865      CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2866      my $class = "CPAN::$type";
2867      my $methods = ['id'];
2868      for my $meth (qw(name)) {
2869          next unless $class->can($meth);
2870          push @$methods, $meth;
2871      }
2872      $self->expand_by_method($class,$methods,@args);
2873  }
2874  
2875  #-> sub CPAN::Shell::expand_by_method ;
2876  sub expand_by_method {
2877      my $self = shift;
2878      my($class,$methods,@args) = @_;
2879      my($arg,@m);
2880      for $arg (@args) {
2881          my($regex,$command);
2882          if ($arg =~ m|^/(.*)/$|) {
2883              $regex = $1;
2884  # FIXME:  there seem to be some ='s in the author data, which trigger
2885  #         a failure here.  This needs to be contemplated.
2886  #            } elsif ($arg =~ m/=/) {
2887  #                $command = 1;
2888          }
2889          my $obj;
2890          CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2891                      $class,
2892                      defined $regex ? $regex : "UNDEFINED",
2893                      defined $command ? $command : "UNDEFINED",
2894                     ) if $CPAN::DEBUG;
2895          if (defined $regex) {
2896              if (CPAN::_sqlite_running) {
2897                  $CPAN::SQLite->search($class, $regex);
2898              }
2899              for $obj (
2900                        $CPAN::META->all_objects($class)
2901                       ) {
2902                  unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
2903                      # BUG, we got an empty object somewhere
2904                      require Data::Dumper;
2905                      CPAN->debug(sprintf(
2906                                          "Bug in CPAN: Empty id on obj[%s][%s]",
2907                                          $obj,
2908                                          Data::Dumper::Dumper($obj)
2909                                         )) if $CPAN::DEBUG;
2910                      next;
2911                  }
2912                  for my $method (@$methods) {
2913                      my $match = eval {$obj->$method() =~ /$regex/i};
2914                      if ($@) {
2915                          my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2916                          $err ||= $@; # if we were too restrictive above
2917                          $CPAN::Frontend->mydie("$err\n");
2918                      } elsif ($match) {
2919                          push @m, $obj;
2920                          last;
2921                      }
2922                  }
2923              }
2924          } elsif ($command) {
2925              die "equal sign in command disabled (immature interface), ".
2926                  "you can set
2927   ! \$CPAN::Shell::ADVANCED_QUERY=1
2928  to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2929  that may go away anytime.\n"
2930                      unless $ADVANCED_QUERY;
2931              my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2932              my($matchcrit) = $criterion =~ m/^~(.+)/;
2933              for my $self (
2934                            sort
2935                            {$a->id cmp $b->id}
2936                            $CPAN::META->all_objects($class)
2937                           ) {
2938                  my $lhs = $self->$method() or next; # () for 5.00503
2939                  if ($matchcrit) {
2940                      push @m, $self if $lhs =~ m/$matchcrit/;
2941                  } else {
2942                      push @m, $self if $lhs eq $criterion;
2943                  }
2944              }
2945          } else {
2946              my($xarg) = $arg;
2947              if ( $class eq 'CPAN::Bundle' ) {
2948                  $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2949              } elsif ($class eq "CPAN::Distribution") {
2950                  $xarg = CPAN::Distribution->normalize($arg);
2951              } else {
2952                  $xarg =~ s/:+/::/g;
2953              }
2954              if ($CPAN::META->exists($class,$xarg)) {
2955                  $obj = $CPAN::META->instance($class,$xarg);
2956              } elsif ($CPAN::META->exists($class,$arg)) {
2957                  $obj = $CPAN::META->instance($class,$arg);
2958              } else {
2959                  next;
2960              }
2961              push @m, $obj;
2962          }
2963      }
2964      @m = sort {$a->id cmp $b->id} @m;
2965      if ( $CPAN::DEBUG ) {
2966          my $wantarray = wantarray;
2967          my $join_m = join ",", map {$_->id} @m;
2968          $self->debug("wantarray[$wantarray]join_m[$join_m]");
2969      }
2970      return wantarray ? @m : $m[0];
2971  }
2972  
2973  #-> sub CPAN::Shell::format_result ;
2974  sub format_result {
2975      my($self) = shift;
2976      my($type,@args) = @_;
2977      @args = '/./' unless @args;
2978      my(@result) = $self->expand($type,@args);
2979      my $result = @result == 1 ?
2980          $result[0]->as_string :
2981              @result == 0 ?
2982                  "No objects of type $type found for argument @args\n" :
2983                      join("",
2984                           (map {$_->as_glimpse} @result),
2985                           scalar @result, " items found\n",
2986                          );
2987      $result;
2988  }
2989  
2990  #-> sub CPAN::Shell::report_fh ;
2991  {
2992      my $installation_report_fh;
2993      my $previously_noticed = 0;
2994  
2995      sub report_fh {
2996          return $installation_report_fh if $installation_report_fh;
2997          if ($CPAN::META->has_usable("File::Temp")) {
2998              $installation_report_fh
2999                  = File::Temp->new(
3000                                    dir      => File::Spec->tmpdir,
3001                                    template => 'cpan_install_XXXX',
3002                                    suffix   => '.txt',
3003                                    unlink   => 0,
3004                                   );
3005          }
3006          unless ( $installation_report_fh ) {
3007              warn("Couldn't open installation report file; " .
3008                   "no report file will be generated."
3009                  ) unless $previously_noticed++;
3010          }
3011      }
3012  }
3013  
3014  
3015  # The only reason for this method is currently to have a reliable
3016  # debugging utility that reveals which output is going through which
3017  # channel. No, I don't like the colors ;-)
3018  
3019  # to turn colordebugging on, write
3020  # cpan> o conf colorize_output 1
3021  
3022  #-> sub CPAN::Shell::print_ornamented ;
3023  {
3024      my $print_ornamented_have_warned = 0;
3025      sub colorize_output {
3026          my $colorize_output = $CPAN::Config->{colorize_output};
3027          if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3028              unless ($print_ornamented_have_warned++) {
3029                  # no myprint/mywarn within myprint/mywarn!
3030                  warn "Colorize_output is set to true but Term::ANSIColor is not
3031  installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3032              }
3033              $colorize_output = 0;
3034          }
3035          return $colorize_output;
3036      }
3037  }
3038  
3039  
3040  #-> sub CPAN::Shell::print_ornamented ;
3041  sub print_ornamented {
3042      my($self,$what,$ornament) = @_;
3043      return unless defined $what;
3044  
3045      local $| = 1; # Flush immediately
3046      if ( $CPAN::Be_Silent ) {
3047          print {report_fh()} $what;
3048          return;
3049      }
3050      my $swhat = "$what"; # stringify if it is an object
3051      if ($CPAN::Config->{term_is_latin}) {
3052          # note: deprecated, need to switch to $LANG and $LC_*
3053          # courtesy jhi:
3054          $swhat
3055              =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3056      }
3057      if ($self->colorize_output) {
3058          if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3059              # if you want to have this configurable, please file a bugreport
3060              $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3061          }
3062          my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3063          if ($@) {
3064              print "Term::ANSIColor rejects color[$ornament]: $@\n
3065  Please choose a different color (Hint: try 'o conf init /color/')\n";
3066          }
3067          # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3068          # $trailer construct. We want the newline be the last thing if
3069          # there is a newline at the end ensuring that the next line is
3070          # empty for other players
3071          my $trailer = "";
3072          $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3073          print $color_on,
3074              $swhat,
3075                  Term::ANSIColor::color("reset"),
3076                        $trailer;
3077      } else {
3078          print $swhat;
3079      }
3080  }
3081  
3082  #-> sub CPAN::Shell::myprint ;
3083  
3084  # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3085  # I think, we send everything to STDOUT and use print for normal/good
3086  # news and warn for news that need more attention. Yes, this is our
3087  # working contract for now.
3088  sub myprint {
3089      my($self,$what) = @_;
3090      $self->print_ornamented($what,
3091                              $CPAN::Config->{colorize_print}||'bold blue on_white',
3092                             );
3093  }
3094  
3095  sub optprint {
3096      my($self,$category,$what) = @_;
3097      my $vname = $category . "_verbosity";
3098      CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3099      if (!$CPAN::Config->{$vname}
3100          || $CPAN::Config->{$vname} =~ /^v/
3101         ) {
3102          $CPAN::Frontend->myprint($what);
3103      }
3104  }
3105  
3106  #-> sub CPAN::Shell::myexit ;
3107  sub myexit {
3108      my($self,$what) = @_;
3109      $self->myprint($what);
3110      exit;
3111  }
3112  
3113  #-> sub CPAN::Shell::mywarn ;
3114  sub mywarn {
3115      my($self,$what) = @_;
3116      $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3117  }
3118  
3119  # only to be used for shell commands
3120  #-> sub CPAN::Shell::mydie ;
3121  sub mydie {
3122      my($self,$what) = @_;
3123      $self->mywarn($what);
3124  
3125      # If it is the shell, we want the following die to be silent,
3126      # but if it is not the shell, we would need a 'die $what'. We need
3127      # to take care that only shell commands use mydie. Is this
3128      # possible?
3129  
3130      die "\n";
3131  }
3132  
3133  # sub CPAN::Shell::colorable_makemaker_prompt ;
3134  sub colorable_makemaker_prompt {
3135      my($foo,$bar) = @_;
3136      if (CPAN::Shell->colorize_output) {
3137          my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3138          my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3139          print $color_on;
3140      }
3141      my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3142      if (CPAN::Shell->colorize_output) {
3143          print Term::ANSIColor::color('reset');
3144      }
3145      return $ans;
3146  }
3147  
3148  # use this only for unrecoverable errors!
3149  #-> sub CPAN::Shell::unrecoverable_error ;
3150  sub unrecoverable_error {
3151      my($self,$what) = @_;
3152      my @lines = split /\n/, $what;
3153      my $longest = 0;
3154      for my $l (@lines) {
3155          $longest = length $l if length $l > $longest;
3156      }
3157      $longest = 62 if $longest > 62;
3158      for my $l (@lines) {
3159          if ($l =~ /^\s*$/) {
3160              $l = "\n";
3161              next;
3162          }
3163          $l = "==> $l";
3164          if (length $l < 66) {
3165              $l = pack "A66 A*", $l, "<==";
3166          }
3167          $l .= "\n";
3168      }
3169      unshift @lines, "\n";
3170      $self->mydie(join "", @lines);
3171  }
3172  
3173  #-> sub CPAN::Shell::mysleep ;
3174  sub mysleep {
3175      my($self, $sleep) = @_;
3176      if (CPAN->has_inst("Time::HiRes")) {
3177          Time::HiRes::sleep($sleep);
3178      } else {
3179          sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3180      }
3181  }
3182  
3183  #-> sub CPAN::Shell::setup_output ;
3184  sub setup_output {
3185      return if -t STDOUT;
3186      my $odef = select STDERR;
3187      $| = 1;
3188      select STDOUT;
3189      $| = 1;
3190      select $odef;
3191  }
3192  
3193  #-> sub CPAN::Shell::rematein ;
3194  # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3195  sub rematein {
3196      my $self = shift;
3197      my($meth,@some) = @_;
3198      my @pragma;
3199      while($meth =~ /^(ff?orce|notest)$/) {
3200          push @pragma, $meth;
3201          $meth = shift @some or
3202              $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3203                                     "cannot continue");
3204      }
3205      setup_output();
3206      CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3207  
3208      # Here is the place to set "test_count" on all involved parties to
3209      # 0. We then can pass this counter on to the involved
3210      # distributions and those can refuse to test if test_count > X. In
3211      # the first stab at it we could use a 1 for "X".
3212  
3213      # But when do I reset the distributions to start with 0 again?
3214      # Jost suggested to have a random or cycling interaction ID that
3215      # we pass through. But the ID is something that is just left lying
3216      # around in addition to the counter, so I'd prefer to set the
3217      # counter to 0 now, and repeat at the end of the loop. But what
3218      # about dependencies? They appear later and are not reset, they
3219      # enter the queue but not its copy. How do they get a sensible
3220      # test_count?
3221  
3222      # With configure_requires, "get" is vulnerable in recursion.
3223  
3224      my $needs_recursion_protection = "get|make|test|install";
3225  
3226      # construct the queue
3227      my($s,@s,@qcopy);
3228    STHING: foreach $s (@some) {
3229          my $obj;
3230          if (ref $s) {
3231              CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3232              $obj = $s;
3233          } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3234          } elsif ($s =~ m|^/|) { # looks like a regexp
3235              if (substr($s,-1,1) eq ".") {
3236                  $obj = CPAN::Shell->expandany($s);
3237              } else {
3238                  $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3239                                          "not supported.\nRejecting argument '$s'\n");
3240                  $CPAN::Frontend->mysleep(2);
3241                  next;
3242              }
3243          } elsif ($meth eq "ls") {
3244              $self->globls($s,\@pragma);
3245              next STHING;
3246          } else {
3247              CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3248              $obj = CPAN::Shell->expandany($s);
3249          }
3250          if (0) {
3251          } elsif (ref $obj) {
3252              if ($meth =~ /^($needs_recursion_protection)$/) {
3253                  # it would be silly to check for recursion for look or dump
3254                  # (we are in CPAN::Shell::rematein)
3255                  CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3256                  eval {  $obj->color_cmd_tmps(0,1); };
3257                  if ($@) {
3258                      if (ref $@
3259                          and $@->isa("CPAN::Exception::RecursiveDependency")) {
3260                          $CPAN::Frontend->mywarn($@);
3261                      } else {
3262                          if (0) {
3263                              require Carp;
3264                              Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3265                          }
3266                          die;
3267                      }
3268                  }
3269              }
3270              CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3271              push @qcopy, $obj;
3272          } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3273              $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3274              if ($meth =~ /^(dump|ls|reports)$/) {
3275                  $obj->$meth();
3276              } else {
3277                  $CPAN::Frontend->mywarn(
3278                                          join "",
3279                                          "Don't be silly, you can't $meth ",
3280                                          $obj->fullname,
3281                                          " ;-)\n"
3282                                         );
3283                  $CPAN::Frontend->mysleep(2);
3284              }
3285          } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3286              CPAN::InfoObj->dump($s);
3287          } else {
3288              $CPAN::Frontend
3289                  ->mywarn(qq{Warning: Cannot $meth $s, }.
3290                           qq{don't know what it is.
3291  Try the command
3292  
3293      i /$s/
3294  
3295  to find objects with matching identifiers.
3296  });
3297              $CPAN::Frontend->mysleep(2);
3298          }
3299      }
3300  
3301      # queuerunner (please be warned: when I started to change the
3302      # queue to hold objects instead of names, I made one or two
3303      # mistakes and never found which. I reverted back instead)
3304      while (my $q = CPAN::Queue->first) {
3305          my $obj;
3306          my $s = $q->as_string;
3307          my $reqtype = $q->reqtype || "";
3308          $obj = CPAN::Shell->expandany($s);
3309          unless ($obj) {
3310              # don't know how this can happen, maybe we should panic,
3311              # but maybe we get a solution from the first user who hits
3312              # this unfortunate exception?
3313              $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3314                                      "to an object. Skipping.\n");
3315              $CPAN::Frontend->mysleep(5);
3316              CPAN::Queue->delete_first($s);
3317              next;
3318          }
3319          $obj->{reqtype} ||= "";
3320          {
3321              # force debugging because CPAN::SQLite somehow delivers us
3322              # an empty object;
3323  
3324              # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3325  
3326              CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3327                          "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3328          }
3329          if ($obj->{reqtype}) {
3330              if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3331                  $obj->{reqtype} = $reqtype;
3332                  if (
3333                      exists $obj->{install}
3334                      &&
3335                      (
3336                       UNIVERSAL::can($obj->{install},"failed") ?
3337                       $obj->{install}->failed :
3338                       $obj->{install} =~ /^NO/
3339                      )
3340                     ) {
3341                      delete $obj->{install};
3342                      $CPAN::Frontend->mywarn
3343                          ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3344                  }
3345              }
3346          } else {
3347              $obj->{reqtype} = $reqtype;
3348          }
3349  
3350          for my $pragma (@pragma) {
3351              if ($pragma
3352                  &&
3353                  $obj->can($pragma)) {
3354                  $obj->$pragma($meth);
3355              }
3356          }
3357          if (UNIVERSAL::can($obj, 'called_for')) {
3358              $obj->called_for($s);
3359          }
3360          CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3361                      qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3362  
3363          push @qcopy, $obj;
3364          if ($meth =~ /^(report)$/) { # they came here with a pragma?
3365              $self->$meth($obj);
3366          } elsif (! UNIVERSAL::can($obj,$meth)) {
3367              # Must never happen
3368              my $serialized = "";
3369              if (0) {
3370              } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3371                  $serialized = YAML::Syck::Dump($obj);
3372              } elsif ($CPAN::META->has_inst("YAML")) {
3373                  $serialized = YAML::Dump($obj);
3374              } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3375                  $serialized = Data::Dumper::Dumper($obj);
3376              } else {
3377                  require overload;
3378                  $serialized = overload::StrVal($obj);
3379              }
3380              CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3381              $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3382          } elsif ($obj->$meth()) {
3383              CPAN::Queue->delete($s);
3384              CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3385          } else {
3386              CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3387          }
3388  
3389          $obj->undelay;
3390          for my $pragma (@pragma) {
3391              my $unpragma = "un$pragma";
3392              if ($obj->can($unpragma)) {
3393                  $obj->$unpragma();
3394              }
3395          }
3396          CPAN::Queue->delete_first($s);
3397      }
3398      if ($meth =~ /^($needs_recursion_protection)$/) {
3399          for my $obj (@qcopy) {
3400              $obj->color_cmd_tmps(0,0);
3401          }
3402      }
3403  }
3404  
3405  #-> sub CPAN::Shell::recent ;
3406  sub recent {
3407    my($self) = @_;
3408    if ($CPAN::META->has_inst("XML::LibXML")) {
3409        my $url = $CPAN::Defaultrecent;
3410        $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3411        unless ($CPAN::META->has_usable("LWP")) {
3412            $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3413        }
3414        CPAN::LWP::UserAgent->config;
3415        my $Ua;
3416        eval { $Ua = CPAN::LWP::UserAgent->new; };
3417        if ($@) {
3418            $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3419        }
3420        my $resp = $Ua->get($url);
3421        unless ($resp->is_success) {
3422            $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3423        }
3424        $CPAN::Frontend->myprint("DONE\n\n");
3425        my $xml = XML::LibXML->new->parse_string($resp->content);
3426        if (0) {
3427            my $s = $xml->serialize(2);
3428            $s =~ s/\n\s*\n/\n/g;
3429            $CPAN::Frontend->myprint($s);
3430            return;
3431        }
3432        my @distros;
3433        if ($url =~ /winnipeg/) {
3434            my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3435            $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3436            for my $eitem ($xml->findnodes("/rss/channel/item")) {
3437                my $distro = $eitem->findvalue("enclosure/\@url");
3438                $distro =~ s|.*?/authors/id/./../||;
3439                my $size   = $eitem->findvalue("enclosure/\@length");
3440                my $desc   = $eitem->findvalue("description");
3441                $desc =~ s/.+? - //;
3442                $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3443                push @distros, $distro;
3444            }
3445        } elsif ($url =~ /search.*uploads.rdf/) {
3446            # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3447            # xmlns="http://purl.org/rss/1.0/"
3448            # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3449            # xmlns:dc="http://purl.org/dc/elements/1.1/"
3450            # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3451            # xmlns:admin="http://webns.net/mvcb/"
3452  
3453  
3454            my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3455            $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3456            my $finish_eitem = 0;
3457            local $SIG{INT} = sub { $finish_eitem = 1 };
3458          EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3459                my $distro = $eitem->findvalue("\@rdf:about");
3460                $distro =~ s|.*~||; # remove up to the tilde before the name
3461                $distro =~ s|/$||; # remove trailing slash
3462                $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3463                my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3464                my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3465                my $i = 0;
3466              SUBDIRTEST: while () {
3467                    last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3468                    if (my @ret = $self->globls("$distro*")) {
3469                        @ret = grep {$_->[2] !~ /meta/} @ret;
3470                        @ret = grep {length $_->[2]} @ret;
3471                        if (@ret) {
3472                            $distro = "$author/$ret[0][2]";
3473                            last SUBDIRTEST;
3474                        }
3475                    }
3476                    $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3477                }
3478  
3479                next EITEM if $distro =~ m|\*|; # did not find the thing
3480                $CPAN::Frontend->myprint("____$desc\n");
3481                push @distros, $distro;
3482                last EITEM if $finish_eitem;
3483            }
3484        }
3485        return \@distros;
3486    } else {
3487        # deprecated old version
3488        $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3489    }
3490  }
3491  
3492  #-> sub CPAN::Shell::smoke ;
3493  sub smoke {
3494      my($self) = @_;
3495      my $distros = $self->recent;
3496    DISTRO: for my $distro (@$distros) {
3497          $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3498          {
3499              my $skip = 0;
3500              local $SIG{INT} = sub { $skip = 1 };
3501              for (0..9) {
3502                  $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3503                  sleep 1;
3504                  if ($skip) {
3505                      $CPAN::Frontend->myprint(" skipped\n");
3506                      next DISTRO;
3507                  }
3508              }
3509          }
3510          $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3511          $self->test($distro);
3512      }
3513  }
3514  
3515  {
3516      # set up the dispatching methods
3517      no strict "refs";
3518      for my $command (qw(
3519                          clean
3520                          cvs_import
3521                          dump
3522                          force
3523                          fforce
3524                          get
3525                          install
3526                          look
3527                          ls
3528                          make
3529                          notest
3530                          perldoc
3531                          readme
3532                          reports
3533                          test
3534                         )) {
3535          *$command = sub { shift->rematein($command, @_); };
3536      }
3537  }
3538  
3539  package CPAN::LWP::UserAgent;
3540  use strict;
3541  
3542  sub config {
3543      return if $SETUPDONE;
3544      if ($CPAN::META->has_usable('LWP::UserAgent')) {
3545          require LWP::UserAgent;
3546          @ISA = qw(Exporter LWP::UserAgent);
3547          $SETUPDONE++;
3548      } else {
3549          $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3550      }
3551  }
3552  
3553  sub get_basic_credentials {
3554      my($self, $realm, $uri, $proxy) = @_;
3555      if ($USER && $PASSWD) {
3556          return ($USER, $PASSWD);
3557      }
3558      if ( $proxy ) {
3559          ($USER,$PASSWD) = $self->get_proxy_credentials();
3560      } else {
3561          ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3562      }
3563      return($USER,$PASSWD);
3564  }
3565  
3566  sub get_proxy_credentials {
3567      my $self = shift;
3568      my ($user, $password);
3569      if ( defined $CPAN::Config->{proxy_user} &&
3570           defined $CPAN::Config->{proxy_pass}) {
3571          $user = $CPAN::Config->{proxy_user};
3572          $password = $CPAN::Config->{proxy_pass};
3573          return ($user, $password);
3574      }
3575      my $username_prompt = "\nProxy authentication needed!
3576   (Note: to permanently configure username and password run
3577     o conf proxy_user your_username
3578     o conf proxy_pass your_password
3579       )\nUsername:";
3580      ($user, $password) =
3581          _get_username_and_password_from_user($username_prompt);
3582      return ($user,$password);
3583  }
3584  
3585  sub get_non_proxy_credentials {
3586      my $self = shift;
3587      my ($user,$password);
3588      if ( defined $CPAN::Config->{username} &&
3589           defined $CPAN::Config->{password}) {
3590          $user = $CPAN::Config->{username};
3591          $password = $CPAN::Config->{password};
3592          return ($user, $password);
3593      }
3594      my $username_prompt = "\nAuthentication needed!
3595       (Note: to permanently configure username and password run
3596         o conf username your_username
3597         o conf password your_password
3598       )\nUsername:";
3599  
3600      ($user, $password) =
3601          _get_username_and_password_from_user($username_prompt);
3602      return ($user,$password);
3603  }
3604  
3605  sub _get_username_and_password_from_user {
3606      my $username_message = shift;
3607      my ($username,$password);
3608  
3609      ExtUtils::MakeMaker->import(qw(prompt));
3610      $username = prompt($username_message);
3611          if ($CPAN::META->has_inst("Term::ReadKey")) {
3612              Term::ReadKey::ReadMode("noecho");
3613          }
3614      else {
3615          $CPAN::Frontend->mywarn(
3616              "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3617          );
3618      }
3619      $password = prompt("Password:");
3620  
3621          if ($CPAN::META->has_inst("Term::ReadKey")) {
3622              Term::ReadKey::ReadMode("restore");
3623          }
3624          $CPAN::Frontend->myprint("\n\n");
3625      return ($username,$password);
3626  }
3627  
3628  # mirror(): Its purpose is to deal with proxy authentication. When we
3629  # call SUPER::mirror, we relly call the mirror method in
3630  # LWP::UserAgent. LWP::UserAgent will then call
3631  # $self->get_basic_credentials or some equivalent and this will be
3632  # $self->dispatched to our own get_basic_credentials method.
3633  
3634  # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3635  
3636  # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3637  # although we have gone through our get_basic_credentials, the proxy
3638  # server refuses to connect. This could be a case where the username or
3639  # password has changed in the meantime, so I'm trying once again without
3640  # $USER and $PASSWD to give the get_basic_credentials routine another
3641  # chance to set $USER and $PASSWD.
3642  
3643  # mirror(): Its purpose is to deal with proxy authentication. When we
3644  # call SUPER::mirror, we relly call the mirror method in
3645  # LWP::UserAgent. LWP::UserAgent will then call
3646  # $self->get_basic_credentials or some equivalent and this will be
3647  # $self->dispatched to our own get_basic_credentials method.
3648  
3649  # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3650  
3651  # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3652  # although we have gone through our get_basic_credentials, the proxy
3653  # server refuses to connect. This could be a case where the username or
3654  # password has changed in the meantime, so I'm trying once again without
3655  # $USER and $PASSWD to give the get_basic_credentials routine another
3656  # chance to set $USER and $PASSWD.
3657  
3658  sub mirror {
3659      my($self,$url,$aslocal) = @_;
3660      my $result = $self->SUPER::mirror($url,$aslocal);
3661      if ($result->code == 407) {
3662          undef $USER;
3663          undef $PASSWD;
3664          $result = $self->SUPER::mirror($url,$aslocal);
3665      }
3666      $result;
3667  }
3668  
3669  package CPAN::FTP;
3670  use strict;
3671  
3672  #-> sub CPAN::FTP::ftp_statistics
3673  # if they want to rewrite, they need to pass in a filehandle
3674  sub _ftp_statistics {
3675      my($self,$fh) = @_;
3676      my $locktype = $fh ? LOCK_EX : LOCK_SH;
3677      $fh ||= FileHandle->new;
3678      my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3679      open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3680      my $sleep = 1;
3681      my $waitstart;
3682      while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3683          $waitstart ||= localtime();
3684          if ($sleep>3) {
3685              $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3686          }
3687          $CPAN::Frontend->mysleep($sleep);
3688          if ($sleep <= 3) {
3689              $sleep+=0.33;
3690          } elsif ($sleep <=6) {
3691              $sleep+=0.11;
3692          }
3693      }
3694      my $stats = eval { CPAN->_yaml_loadfile($file); };
3695      if ($@) {
3696          if (ref $@) {
3697              if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3698                  $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3699                  return;
3700              } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3701                  $CPAN::Frontend->mydie($@);
3702              }
3703          } else {
3704              $CPAN::Frontend->mydie($@);
3705          }
3706      }
3707      return $stats->[0];
3708  }
3709  
3710  #-> sub CPAN::FTP::_mytime
3711  sub _mytime () {
3712      if (CPAN->has_inst("Time::HiRes")) {
3713          return Time::HiRes::time();
3714      } else {
3715          return time;
3716      }
3717  }
3718  
3719  #-> sub CPAN::FTP::_new_stats
3720  sub _new_stats {
3721      my($self,$file) = @_;
3722      my $ret = {
3723                 file => $file,
3724                 attempts => [],
3725                 start => _mytime,
3726                };
3727      $ret;
3728  }
3729  
3730  #-> sub CPAN::FTP::_add_to_statistics
3731  sub _add_to_statistics {
3732      my($self,$stats) = @_;
3733      my $yaml_module = CPAN::_yaml_module;
3734      $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3735      if ($CPAN::META->has_inst($yaml_module)) {
3736          $stats->{thesiteurl} = $ThesiteURL;
3737          if (CPAN->has_inst("Time::HiRes")) {
3738              $stats->{end} = Time::HiRes::time();
3739          } else {
3740              $stats->{end} = time;
3741          }
3742          my $fh = FileHandle->new;
3743          my $time = time;
3744          my $sdebug = 0;
3745          my @debug;
3746          @debug = $time if $sdebug;
3747          my $fullstats = $self->_ftp_statistics($fh);
3748          close $fh;
3749          $fullstats->{history} ||= [];
3750          push @debug, scalar @{$fullstats->{history}} if $sdebug;
3751          push @debug, time if $sdebug;
3752          push @{$fullstats->{history}}, $stats;
3753          # arbitrary hardcoded constants until somebody demands to have
3754          # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3755          # YAML::Syck 0.82 has no noticable performance problem with 999;
3756          while (
3757                 @{$fullstats->{history}} > 99
3758                 || $time - $fullstats->{history}[0]{start} > 14*86400
3759                ) {
3760              shift @{$fullstats->{history}}
3761          }
3762          push @debug, scalar @{$fullstats->{history}} if $sdebug;
3763          push @debug, time if $sdebug;
3764          push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3765          # need no eval because if this fails, it is serious
3766          my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3767          CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3768          if ( $sdebug ) {
3769              local $CPAN::DEBUG = 512; # FTP
3770              push @debug, time;
3771              CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3772                                  "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3773                                  @debug,
3774                                 ));
3775          }
3776          # Win32 cannot rename a file to an existing filename
3777          unlink($sfile) if ($^O eq 'MSWin32');
3778          rename "$sfile.$$", $sfile
3779              or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3780      }
3781  }
3782  
3783  # if file is CHECKSUMS, suggest the place where we got the file to be
3784  # checked from, maybe only for young files?
3785  #-> sub CPAN::FTP::_recommend_url_for
3786  sub _recommend_url_for {
3787      my($self, $file) = @_;
3788      my $urllist = $self->_get_urllist;
3789      if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3790          my $fullstats = $self->_ftp_statistics();
3791          my $history = $fullstats->{history} || [];
3792          while (my $last = pop @$history) {
3793              last if $last->{end} - time > 3600; # only young results are interesting
3794              next unless $last->{file}; # dirname of nothing dies!
3795              next unless $file eq File::Basename::dirname($last->{file});
3796              return $last->{thesiteurl};
3797          }
3798      }
3799      if ($CPAN::Config->{randomize_urllist}
3800          &&
3801          rand(1) < $CPAN::Config->{randomize_urllist}
3802         ) {
3803          $urllist->[int rand scalar @$urllist];
3804      } else {
3805          return ();
3806      }
3807  }
3808  
3809  #-> sub CPAN::FTP::_get_urllist
3810  sub _get_urllist {
3811      my($self) = @_;
3812      $CPAN::Config->{urllist} ||= [];
3813      unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3814          $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3815          $CPAN::Config->{urllist} = [];
3816      }
3817      my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3818      for my $u (@urllist) {
3819          CPAN->debug("u[$u]") if $CPAN::DEBUG;
3820          if (UNIVERSAL::can($u,"text")) {
3821              $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3822          } else {
3823              $u .= "/" unless substr($u,-1) eq "/";
3824              $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3825          }
3826      }
3827      \@urllist;
3828  }
3829  
3830  #-> sub CPAN::FTP::ftp_get ;
3831  sub ftp_get {
3832      my($class,$host,$dir,$file,$target) = @_;
3833      $class->debug(
3834                    qq[Going to fetch file [$file] from dir [$dir]
3835      on host [$host] as local [$target]\n]
3836                   ) if $CPAN::DEBUG;
3837      my $ftp = Net::FTP->new($host);
3838      unless ($ftp) {
3839          $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3840          return;
3841      }
3842      return 0 unless defined $ftp;
3843      $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3844      $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3845      unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
3846          my $msg = $ftp->message;
3847          $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3848          return;
3849      }
3850      unless ( $ftp->cwd($dir) ) {
3851          my $msg = $ftp->message;
3852          $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3853          return;
3854      }
3855      $ftp->binary;
3856      $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3857      unless ( $ftp->get($file,$target) ) {
3858          my $msg = $ftp->message;
3859          $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3860          return;
3861      }
3862      $ftp->quit; # it's ok if this fails
3863      return 1;
3864  }
3865  
3866  # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3867  
3868   # > *** /install/perl/live/lib/CPAN.pm-    Wed Sep 24 13:08:48 1997
3869   # > --- /tmp/cp    Wed Sep 24 13:26:40 1997
3870   # > ***************
3871   # > *** 1562,1567 ****
3872   # > --- 1562,1580 ----
3873   # >       return 1 if substr($url,0,4) eq "file";
3874   # >       return 1 unless $url =~ m|://([^/]+)|;
3875   # >       my $host = $1;
3876   # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3877   # > +     if ($proxy) {
3878   # > +         $proxy =~ m|://([^/:]+)|;
3879   # > +         $proxy = $1;
3880   # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3881   # > +         if ($noproxy) {
3882   # > +             if ($host !~ /$noproxy$/) {
3883   # > +                 $host = $proxy;
3884   # > +             }
3885   # > +         } else {
3886   # > +             $host = $proxy;
3887   # > +         }
3888   # > +     }
3889   # >       require Net::Ping;
3890   # >       return 1 unless $Net::Ping::VERSION >= 2;
3891   # >       my $p;
3892  
3893  
3894  #-> sub CPAN::FTP::localize ;
3895  sub localize {
3896      my($self,$file,$aslocal,$force) = @_;
3897      $force ||= 0;
3898      Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3899          unless defined $aslocal;
3900      $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3901          if $CPAN::DEBUG;
3902  
3903      if ($^O eq 'MacOS') {
3904          # Comment by AK on 2000-09-03: Uniq short filenames would be
3905          # available in CHECKSUMS file
3906          my($name, $path) = File::Basename::fileparse($aslocal, '');
3907          if (length($name) > 31) {
3908              $name =~ s/(
3909                          \.(
3910                             readme(\.(gz|Z))? |
3911                             (tar\.)?(gz|Z) |
3912                             tgz |
3913                             zip |
3914                             pm\.(gz|Z)
3915                            )
3916                         )$//x;
3917              my $suf = $1;
3918              my $size = 31 - length($suf);
3919              while (length($name) > $size) {
3920                  chop $name;
3921              }
3922              $name .= $suf;
3923              $aslocal = File::Spec->catfile($path, $name);
3924          }
3925      }
3926  
3927      if (-f $aslocal && -r _ && !($force & 1)) {
3928          my $size;
3929          if ($size = -s $aslocal) {
3930              $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3931              return $aslocal;
3932          } else {
3933              # empty file from a previous unsuccessful attempt to download it
3934              unlink $aslocal or
3935                  $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3936                                         "could not remove.");
3937          }
3938      }
3939      my($maybe_restore) = 0;
3940      if (-f $aslocal) {
3941          rename $aslocal, "$aslocal.bak$$";
3942          $maybe_restore++;
3943      }
3944  
3945      my($aslocal_dir) = File::Basename::dirname($aslocal);
3946      $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
3947      # Inheritance is not easier to manage than a few if/else branches
3948      if ($CPAN::META->has_usable('LWP::UserAgent')) {
3949          unless ($Ua) {
3950              CPAN::LWP::UserAgent->config;
3951              eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3952              if ($@) {
3953                  $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3954                      if $CPAN::DEBUG;
3955              } else {
3956                  my($var);
3957                  $Ua->proxy('ftp',  $var)
3958                      if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3959                  $Ua->proxy('http', $var)
3960                      if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3961                  $Ua->no_proxy($var)
3962                      if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3963              }
3964          }
3965      }
3966      for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3967          $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3968      }
3969  
3970      # Try the list of urls for each single object. We keep a record
3971      # where we did get a file from
3972      my(@reordered,$last);
3973      my $ccurllist = $self->_get_urllist;
3974      $last = $#$ccurllist;
3975      if ($force & 2) { # local cpans probably out of date, don't reorder
3976          @reordered = (0..$last);
3977      } else {
3978          @reordered =
3979              sort {
3980                  (substr($ccurllist->[$b],0,4) eq "file")
3981                      <=>
3982                  (substr($ccurllist->[$a],0,4) eq "file")
3983                      or
3984                  defined($ThesiteURL)
3985                      and
3986                  ($ccurllist->[$b] eq $ThesiteURL)
3987                      <=>
3988                  ($ccurllist->[$a] eq $ThesiteURL)
3989              } 0..$last;
3990      }
3991      my(@levels);
3992      $Themethod ||= "";
3993      $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3994      my @all_levels = (
3995                        ["dleasy",   "file"],
3996                        ["dleasy"],
3997                        ["dlhard"],
3998                        ["dlhardest"],
3999                        ["dleasy",   "http","defaultsites"],
4000                        ["dlhard",   "http","defaultsites"],
4001                        ["dleasy",   "ftp", "defaultsites"],
4002                        ["dlhard",   "ftp", "defaultsites"],
4003                        ["dlhardest","",    "defaultsites"],
4004                       );
4005      if ($Themethod) {
4006          @levels = grep {$_->[0] eq $Themethod} @all_levels;
4007          push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4008      } else {
4009          @levels = @all_levels;
4010      }
4011      @levels = qw/dleasy/ if $^O eq 'MacOS';
4012      my($levelno);
4013      local $ENV{FTP_PASSIVE} =
4014          exists $CPAN::Config->{ftp_passive} ?
4015          $CPAN::Config->{ftp_passive} : 1;
4016      my $ret;
4017      my $stats = $self->_new_stats($file);
4018    LEVEL: for $levelno (0..$#levels) {
4019          my $level_tuple = $levels[$levelno];
4020          my($level,$scheme,$sitetag) = @$level_tuple;
4021          my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4022          my @urllist;
4023          if ($defaultsites) {
4024              unless (defined $connect_to_internet_ok) {
4025                  $CPAN::Frontend->myprint(sprintf qq{
4026  I would like to connect to one of the following sites to get '%s':
4027  
4028  %s
4029  },
4030                                           $file,
4031                                           join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4032                                          );
4033                  my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4034                  if ($answer =~ /^y/i) {
4035                      $connect_to_internet_ok = 1;
4036                  } else {
4037                      $connect_to_internet_ok = 0;
4038                  }
4039              }
4040              if ($connect_to_internet_ok) {
4041                  @urllist = @CPAN::Defaultsites;
4042              } else {
4043                  @urllist = ();
4044              }
4045          } else {
4046              my @host_seq = $level =~ /dleasy/ ?
4047                  @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4048              @urllist = map { $ccurllist->[$_] } @host_seq;
4049          }
4050          $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4051          my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4052          if (my $recommend = $self->_recommend_url_for($file)) {
4053              @urllist = grep { $_ ne $recommend } @urllist;
4054              unshift @urllist, $recommend;
4055          }
4056          $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4057          $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4058          if ($ret) {
4059              CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4060              if ($ret eq $aslocal_tempfile) {
4061                  # if we got it exactly as we asked for, only then we
4062                  # want to rename
4063                  rename $aslocal_tempfile, $aslocal
4064                      or $CPAN::Frontend->mydie("Error while trying to rename ".
4065                                                "'$ret' to '$aslocal': $!");
4066                  $ret = $aslocal;
4067              }
4068              $Themethod = $level;
4069              my $now = time;
4070              # utime $now, $now, $aslocal; # too bad, if we do that, we
4071                                            # might alter a local mirror
4072              $self->debug("level[$level]") if $CPAN::DEBUG;
4073              last LEVEL;
4074          } else {
4075              unlink $aslocal_tempfile;
4076              last if $CPAN::Signal; # need to cleanup
4077          }
4078      }
4079      if ($ret) {
4080          $stats->{filesize} = -s $ret;
4081      }
4082      $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4083      $self->_add_to_statistics($stats);
4084      $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4085      if ($ret) {
4086          unlink "$aslocal.bak$$";
4087          return $ret;
4088      }
4089      unless ($CPAN::Signal) {
4090          my(@mess);
4091          local $" = " ";
4092          if (@{$CPAN::Config->{urllist}}) {
4093              push @mess,
4094                  qq{Please check, if the URLs I found in your configuration file \(}.
4095                      join(", ", @{$CPAN::Config->{urllist}}).
4096                          qq{\) are valid.};
4097          } else {
4098              push @mess, qq{Your urllist is empty!};
4099          }
4100          push @mess, qq{The urllist can be edited.},
4101              qq{E.g. with 'o conf urllist push ftp://myurl/'};
4102          $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4103          $CPAN::Frontend->mywarn("Could not fetch $file\n");
4104          $CPAN::Frontend->mysleep(2);
4105      }
4106      if ($maybe_restore) {
4107          rename "$aslocal.bak$$", $aslocal;
4108          $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4109                                   $self->ls($aslocal));
4110          return $aslocal;
4111      }
4112      return;
4113  }
4114  
4115  sub mymkpath {
4116      my($self, $aslocal_dir) = @_;
4117      File::Path::mkpath($aslocal_dir);
4118      $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4119                              qq{directory "$aslocal_dir".
4120      I\'ll continue, but if you encounter problems, they may be due
4121      to insufficient permissions.\n}) unless -w $aslocal_dir;
4122  }
4123  
4124  sub hostdlxxx {
4125      my $self = shift;
4126      my $level = shift;
4127      my $scheme = shift;
4128      my $h = shift;
4129      $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4130      my $method = "host$level";
4131      $self->$method($h, @_);
4132  }
4133  
4134  sub _set_attempt {
4135      my($self,$stats,$method,$url) = @_;
4136      push @{$stats->{attempts}}, {
4137                                   method => $method,
4138                                   start => _mytime,
4139                                   url => $url,
4140                                  };
4141  }
4142  
4143  # package CPAN::FTP;
4144  sub hostdleasy {
4145      my($self,$host_seq,$file,$aslocal,$stats) = @_;
4146      my($ro_url);
4147    HOSTEASY: for $ro_url (@$host_seq) {
4148          $self->_set_attempt($stats,"dleasy",$ro_url);
4149          my $url .= "$ro_url$file";
4150          $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4151          if ($url =~ /^file:/) {
4152              my $l;
4153              if ($CPAN::META->has_inst('URI::URL')) {
4154                  my $u =  URI::URL->new($url);
4155                  $l = $u->path;
4156              } else { # works only on Unix, is poorly constructed, but
4157                  # hopefully better than nothing.
4158                  # RFC 1738 says fileurl BNF is
4159                  # fileurl = "file://" [ host | "localhost" ] "/" fpath
4160                  # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4161                  # the code
4162                  ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4163                  $l =~ s|^file:||;                   # assume they
4164                                                      # meant
4165                                                      # file://localhost
4166                  $l =~ s|^/||s
4167                      if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4168              }
4169              $self->debug("local file[$l]") if $CPAN::DEBUG;
4170              if ( -f $l && -r _) {
4171                  $ThesiteURL = $ro_url;
4172                  return $l;
4173              }
4174              if ($l =~ /(.+)\.gz$/) {
4175                  my $ungz = $1;
4176                  if ( -f $ungz && -r _) {
4177                      $ThesiteURL = $ro_url;
4178                      return $ungz;
4179                  }
4180              }
4181              # Maybe mirror has compressed it?
4182              if (-f "$l.gz") {
4183                  $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4184                  eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4185                  if ( -f $aslocal) {
4186                      $ThesiteURL = $ro_url;
4187                      return $aslocal;
4188                  }
4189              }
4190              $CPAN::Frontend->mywarn("Could not find '$l'\n");
4191          }
4192          $self->debug("it was not a file URL") if $CPAN::DEBUG;
4193          if ($CPAN::META->has_usable('LWP')) {
4194              $CPAN::Frontend->myprint("Fetching with LWP:
4195    $url
4196  ");
4197              unless ($Ua) {
4198                  CPAN::LWP::UserAgent->config;
4199                  eval { $Ua = CPAN::LWP::UserAgent->new; };
4200                  if ($@) {
4201                      $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4202                  }
4203              }
4204              my $res = $Ua->mirror($url, $aslocal);
4205              if ($res->is_success) {
4206                  $ThesiteURL = $ro_url;
4207                  my $now = time;
4208                  utime $now, $now, $aslocal; # download time is more
4209                                              # important than upload
4210                                              # time
4211                  return $aslocal;
4212              } elsif ($url !~ /\.gz(?!\n)\Z/) {
4213                  my $gzurl = "$url.gz";
4214                  $CPAN::Frontend->myprint("Fetching with LWP:
4215    $gzurl
4216  ");
4217                  $res = $Ua->mirror($gzurl, "$aslocal.gz");
4218                  if ($res->is_success) {
4219                      if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4220                          $ThesiteURL = $ro_url;
4221                          return $aslocal;
4222                      }
4223                  }
4224              } else {
4225                  $CPAN::Frontend->myprint(sprintf(
4226                                                   "LWP failed with code[%s] message[%s]\n",
4227                                                   $res->code,
4228                                                   $res->message,
4229                                                  ));
4230                  # Alan Burlison informed me that in firewall environments
4231                  # Net::FTP can still succeed where LWP fails. So we do not
4232                  # skip Net::FTP anymore when LWP is available.
4233              }
4234          } else {
4235              $CPAN::Frontend->mywarn("  LWP not available\n");
4236          }
4237          return if $CPAN::Signal;
4238          if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4239              # that's the nice and easy way thanks to Graham
4240              $self->debug("recognized ftp") if $CPAN::DEBUG;
4241              my($host,$dir,$getfile) = ($1,$2,$3);
4242              if ($CPAN::META->has_usable('Net::FTP')) {
4243                  $dir =~ s|/+|/|g;
4244                  $CPAN::Frontend->myprint("Fetching with Net::FTP:
4245    $url
4246  ");
4247                  $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4248                               "aslocal[$aslocal]") if $CPAN::DEBUG;
4249                  if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4250                      $ThesiteURL = $ro_url;
4251                      return $aslocal;
4252                  }
4253                  if ($aslocal !~ /\.gz(?!\n)\Z/) {
4254                      my $gz = "$aslocal.gz";
4255                      $CPAN::Frontend->myprint("Fetching with Net::FTP
4256    $url.gz
4257  ");
4258                      if (CPAN::FTP->ftp_get($host,
4259                                             $dir,
4260                                             "$getfile.gz",
4261                                             $gz) &&
4262                          eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4263                      ) {
4264                          $ThesiteURL = $ro_url;
4265                          return $aslocal;
4266                      }
4267                  }
4268                  # next HOSTEASY;
4269              } else {
4270                  CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4271              }
4272          }
4273          if (
4274              UNIVERSAL::can($ro_url,"text")
4275              and
4276              $ro_url->{FROM} eq "USER"
4277             ) {
4278              ##address #17973: default URLs should not try to override
4279              ##user-defined URLs just because LWP is not available
4280              my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4281              return $ret if $ret;
4282          }
4283          return if $CPAN::Signal;
4284      }
4285  }
4286  
4287  # package CPAN::FTP;
4288  sub hostdlhard {
4289      my($self,$host_seq,$file,$aslocal,$stats) = @_;
4290  
4291      # Came back if Net::FTP couldn't establish connection (or
4292      # failed otherwise) Maybe they are behind a firewall, but they
4293      # gave us a socksified (or other) ftp program...
4294  
4295      my($ro_url);
4296      my($devnull) = $CPAN::Config->{devnull} || "";
4297      # < /dev/null ";
4298      my($aslocal_dir) = File::Basename::dirname($aslocal);
4299      File::Path::mkpath($aslocal_dir);
4300    HOSTHARD: for $ro_url (@$host_seq) {
4301          $self->_set_attempt($stats,"dlhard",$ro_url);
4302          my $url = "$ro_url$file";
4303          my($proto,$host,$dir,$getfile);
4304  
4305          # Courtesy Mark Conty mark_conty@cargill.com change from
4306          # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4307          # to
4308          if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4309              # proto not yet used
4310              ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4311          } else {
4312              next HOSTHARD; # who said, we could ftp anything except ftp?
4313          }
4314          next HOSTHARD if $proto eq "file"; # file URLs would have had
4315                                             # success above. Likely a bogus URL
4316  
4317          $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4318  
4319          # Try the most capable first and leave ncftp* for last as it only
4320          # does FTP.
4321        DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4322              my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4323              next unless defined $funkyftp;
4324              next if $funkyftp =~ /^\s*$/;
4325  
4326              my($asl_ungz, $asl_gz);
4327              ($asl_ungz = $aslocal) =~ s/\.gz//;
4328                  $asl_gz = "$asl_ungz.gz";
4329  
4330              my($src_switch) = "";
4331              my($chdir) = "";
4332              my($stdout_redir) = " > $asl_ungz";
4333              if ($f eq "lynx") {
4334                  $src_switch = " -source";
4335              } elsif ($f eq "ncftp") {
4336                  $src_switch = " -c";
4337              } elsif ($f eq "wget") {
4338                  $src_switch = " -O $asl_ungz";
4339                  $stdout_redir = "";
4340              } elsif ($f eq 'curl') {
4341                  $src_switch = ' -L -f -s -S --netrc-optional';
4342              }
4343  
4344              if ($f eq "ncftpget") {
4345                  $chdir = "cd $aslocal_dir && ";
4346                  $stdout_redir = "";
4347              }
4348              $CPAN::Frontend->myprint(
4349                                       qq[
4350  Trying with "$funkyftp$src_switch" to get
4351      $url
4352  ]);
4353              my($system) =
4354                  "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4355              $self->debug("system[$system]") if $CPAN::DEBUG;
4356              my($wstatus) = system($system);
4357              if ($f eq "lynx") {
4358                  # lynx returns 0 when it fails somewhere
4359                  if (-s $asl_ungz) {
4360                      my $content = do { local *FH;
4361                                         open FH, $asl_ungz or die;
4362                                         local $/;
4363                                         <FH> };
4364                      if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4365                          $CPAN::Frontend->mywarn(qq{
4366  No success, the file that lynx has downloaded looks like an error message:
4367  $content
4368  });
4369                          $CPAN::Frontend->mysleep(1);
4370                          next DLPRG;
4371                      }
4372                  } else {
4373                      $CPAN::Frontend->myprint(qq{
4374  No success, the file that lynx has downloaded is an empty file.
4375  });
4376                      next DLPRG;
4377                  }
4378              }
4379              if ($wstatus == 0) {
4380                  if (-s $aslocal) {
4381                      # Looks good
4382                  } elsif ($asl_ungz ne $aslocal) {
4383                      # test gzip integrity
4384                      if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4385                          # e.g. foo.tar is gzipped --> foo.tar.gz
4386                          rename $asl_ungz, $aslocal;
4387                      } else {
4388                          eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4389                      }
4390                  }
4391                  $ThesiteURL = $ro_url;
4392                  return $aslocal;
4393              } elsif ($url !~ /\.gz(?!\n)\Z/) {
4394                  unlink $asl_ungz if
4395                      -f $asl_ungz && -s _ == 0;
4396                  my $gz = "$aslocal.gz";
4397                  my $gzurl = "$url.gz";
4398                  $CPAN::Frontend->myprint(
4399                                          qq[
4400      Trying with "$funkyftp$src_switch" to get
4401      $url.gz
4402      ]);
4403                  my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4404                  $self->debug("system[$system]") if $CPAN::DEBUG;
4405                  my($wstatus);
4406                  if (($wstatus = system($system)) == 0
4407                      &&
4408                      -s $asl_gz
4409                  ) {
4410                      # test gzip integrity
4411                      my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4412                      if ($ct && $ct->gtest) {
4413                          $ct->gunzip($aslocal);
4414                      } else {
4415                          # somebody uncompressed file for us?
4416                          rename $asl_ungz, $aslocal;
4417                      }
4418                      $ThesiteURL = $ro_url;
4419                      return $aslocal;
4420                  } else {
4421                      unlink $asl_gz if -f $asl_gz;
4422                  }
4423              } else {
4424                  my $estatus = $wstatus >> 8;
4425                  my $size = -f $aslocal ?
4426                      ", left\n$aslocal with size ".-s _ :
4427                      "\nWarning: expected file [$aslocal] doesn't exist";
4428                  $CPAN::Frontend->myprint(qq{
4429      System call "$system"
4430      returned status $estatus (wstat $wstatus)$size
4431      });
4432              }
4433              return if $CPAN::Signal;
4434          } # transfer programs
4435      } # host
4436  }
4437  
4438  # package CPAN::FTP;
4439  sub hostdlhardest {
4440      my($self,$host_seq,$file,$aslocal,$stats) = @_;
4441  
4442      return unless @$host_seq;
4443      my($ro_url);
4444      my($aslocal_dir) = File::Basename::dirname($aslocal);
4445      File::Path::mkpath($aslocal_dir);
4446      my $ftpbin = $CPAN::Config->{ftp};
4447      unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4448          $CPAN::Frontend->myprint("No external ftp command available\n\n");
4449          return;
4450      }
4451      $CPAN::Frontend->mywarn(qq{
4452  As a last ressort we now switch to the external ftp command '$ftpbin'
4453  to get '$aslocal'.
4454  
4455  Doing so often leads to problems that are hard to diagnose.
4456  
4457  If you're victim of such problems, please consider unsetting the ftp
4458  config variable with
4459  
4460      o conf ftp ""
4461      o conf commit
4462  
4463  });
4464      $CPAN::Frontend->mysleep(2);
4465    HOSTHARDEST: for $ro_url (@$host_seq) {
4466          $self->_set_attempt($stats,"dlhardest",$ro_url);
4467          my $url = "$ro_url$file";
4468          $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4469          unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4470              next;
4471          }
4472          my($host,$dir,$getfile) = ($1,$2,$3);
4473          my $timestamp = 0;
4474          my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4475              $ctime,$blksize,$blocks) = stat($aslocal);
4476          $timestamp = $mtime ||= 0;
4477          my($netrc) = CPAN::FTP::netrc->new;
4478          my($netrcfile) = $netrc->netrc;
4479          my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4480          my $targetfile = File::Basename::basename($aslocal);
4481          my(@dialog);
4482          push(
4483               @dialog,
4484               "lcd $aslocal_dir",
4485               "cd /",
4486               map("cd $_", split /\//, $dir), # RFC 1738
4487               "bin",
4488               "get $getfile $targetfile",
4489               "quit"
4490          );
4491          if (! $netrcfile) {
4492              CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4493          } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4494              CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4495                                  $netrc->hasdefault,
4496                                  $netrc->contains($host))) if $CPAN::DEBUG;
4497              if ($netrc->protected) {
4498                  my $dialog = join "", map { "    $_\n" } @dialog;
4499                  my $netrc_explain;
4500                  if ($netrc->contains($host)) {
4501                      $netrc_explain = "Relying that your .netrc entry for '$host' ".
4502                          "manages the login";
4503                  } else {
4504                      $netrc_explain = "Relying that your default .netrc entry ".
4505                          "manages the login";
4506                  }
4507                  $CPAN::Frontend->myprint(qq{
4508    Trying with external ftp to get
4509      $url
4510    $netrc_explain
4511    Going to send the dialog
4512  $dialog
4513  }
4514                  );
4515                  $self->talk_ftp("$ftpbin$verbose $host",
4516                                  @dialog);
4517                  ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4518                      $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4519                  $mtime ||= 0;
4520                  if ($mtime > $timestamp) {
4521                      $CPAN::Frontend->myprint("GOT $aslocal\n");
4522                      $ThesiteURL = $ro_url;
4523                      return $aslocal;
4524                  } else {
4525                      $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4526                  }
4527                      return if $CPAN::Signal;
4528              } else {
4529                  $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4530                                          qq{correctly protected.\n});
4531              }
4532          } else {
4533              $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4534    nor does it have a default entry\n");
4535          }
4536  
4537          # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4538          # then and login manually to host, using e-mail as
4539          # password.
4540          $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4541          unshift(
4542                  @dialog,
4543                  "open $host",
4544                  "user anonymous $Config::Config{'cf_email'}"
4545          );
4546          my $dialog = join "", map { "    $_\n" } @dialog;
4547          $CPAN::Frontend->myprint(qq{
4548    Trying with external ftp to get
4549      $url
4550    Going to send the dialog
4551  $dialog
4552  }
4553          );
4554          $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4555          ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4556              $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4557          $mtime ||= 0;
4558          if ($mtime > $timestamp) {
4559              $CPAN::Frontend->myprint("GOT $aslocal\n");
4560              $ThesiteURL = $ro_url;
4561              return $aslocal;
4562          } else {
4563              $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4564          }
4565          return if $CPAN::Signal;
4566          $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4567          $CPAN::Frontend->mysleep(2);
4568      } # host
4569  }
4570  
4571  # package CPAN::FTP;
4572  sub talk_ftp {
4573      my($self,$command,@dialog) = @_;
4574      my $fh = FileHandle->new;
4575      $fh->open("|$command") or die "Couldn't open ftp: $!";
4576      foreach (@dialog) { $fh->print("$_\n") }
4577      $fh->close; # Wait for process to complete
4578      my $wstatus = $?;
4579      my $estatus = $wstatus >> 8;
4580      $CPAN::Frontend->myprint(qq{
4581  Subprocess "|$command"
4582    returned status $estatus (wstat $wstatus)
4583  }) if $wstatus;
4584  }
4585  
4586  # find2perl needs modularization, too, all the following is stolen
4587  # from there
4588  # CPAN::FTP::ls
4589  sub ls {
4590      my($self,$name) = @_;
4591      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4592       $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4593  
4594      my($perms,%user,%group);
4595      my $pname = $name;
4596  
4597      if ($blocks) {
4598          $blocks = int(($blocks + 1) / 2);
4599      }
4600      else {
4601          $blocks = int(($sizemm + 1023) / 1024);
4602      }
4603  
4604      if    (-f _) { $perms = '-'; }
4605      elsif (-d _) { $perms = 'd'; }
4606      elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4607      elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4608      elsif (-p _) { $perms = 'p'; }
4609      elsif (-S _) { $perms = 's'; }
4610      else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4611  
4612      my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4613      my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4614      my $tmpmode = $mode;
4615      my $tmp = $rwx[$tmpmode & 7];
4616      $tmpmode >>= 3;
4617      $tmp = $rwx[$tmpmode & 7] . $tmp;
4618      $tmpmode >>= 3;
4619      $tmp = $rwx[$tmpmode & 7] . $tmp;
4620      substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4621      substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4622      substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4623      $perms .= $tmp;
4624  
4625      my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4626      my $group = $group{$gid} || $gid;
4627  
4628      my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4629      my($timeyear);
4630      my($moname) = $moname[$mon];
4631      if (-M _ > 365.25 / 2) {
4632          $timeyear = $year + 1900;
4633      }
4634      else {
4635          $timeyear = sprintf("%02d:%02d", $hour, $min);
4636      }
4637  
4638      sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4639               $ino,
4640                    $blocks,
4641                         $perms,
4642                               $nlink,
4643                                   $user,
4644                                        $group,
4645                                             $sizemm,
4646                                                 $moname,
4647                                                    $mday,
4648                                                        $timeyear,
4649                                                            $pname;
4650  }
4651  
4652  package CPAN::FTP::netrc;
4653  use strict;
4654  
4655  # package CPAN::FTP::netrc;
4656  sub new {
4657      my($class) = @_;
4658      my $home = CPAN::HandleConfig::home;
4659      my $file = File::Spec->catfile($home,".netrc");
4660  
4661      my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4662         $atime,$mtime,$ctime,$blksize,$blocks)
4663          = stat($file);
4664      $mode ||= 0;
4665      my $protected = 0;
4666  
4667      my($fh,@machines,$hasdefault);
4668      $hasdefault = 0;
4669      $fh = FileHandle->new or die "Could not create a filehandle";
4670  
4671      if($fh->open($file)) {
4672          $protected = ($mode & 077) == 0;
4673          local($/) = "";
4674        NETRC: while (<$fh>) {
4675              my(@tokens) = split " ", $_;
4676            TOKEN: while (@tokens) {
4677                  my($t) = shift @tokens;
4678                  if ($t eq "default") {
4679                      $hasdefault++;
4680                      last NETRC;
4681                  }
4682                  last TOKEN if $t eq "macdef";
4683                  if ($t eq "machine") {
4684                      push @machines, shift @tokens;
4685                  }
4686              }
4687          }
4688      } else {
4689          $file = $hasdefault = $protected = "";
4690      }
4691  
4692      bless {
4693          'mach' => [@machines],
4694          'netrc' => $file,
4695          'hasdefault' => $hasdefault,
4696          'protected' => $protected,
4697      }, $class;
4698  }
4699  
4700  # CPAN::FTP::netrc::hasdefault;
4701  sub hasdefault { shift->{'hasdefault'} }
4702  sub netrc      { shift->{'netrc'}      }
4703  sub protected  { shift->{'protected'}  }
4704  sub contains {
4705      my($self,$mach) = @_;
4706      for ( @{$self->{'mach'}} ) {
4707          return 1 if $_ eq $mach;
4708      }
4709      return 0;
4710  }
4711  
4712  package CPAN::Complete;
4713  use strict;
4714  
4715  sub gnu_cpl {
4716      my($text, $line, $start, $end) = @_;
4717      my(@perlret) = cpl($text, $line, $start);
4718      # find longest common match. Can anybody show me how to peruse
4719      # T::R::Gnu to have this done automatically? Seems expensive.
4720      return () unless @perlret;
4721      my($newtext) = $text;
4722      for (my $i = length($text)+1;;$i++) {
4723          last unless length($perlret[0]) && length($perlret[0]) >= $i;
4724          my $try = substr($perlret[0],0,$i);
4725          my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4726          # warn "try[$try]tries[@tries]";
4727          if (@tries == @perlret) {
4728              $newtext = $try;
4729          } else {
4730              last;
4731          }
4732      }
4733      ($newtext,@perlret);
4734  }
4735  
4736  #-> sub CPAN::Complete::cpl ;
4737  sub cpl {
4738      my($word,$line,$pos) = @_;
4739      $word ||= "";
4740      $line ||= "";
4741      $pos ||= 0;
4742      CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4743      $line =~ s/^\s*//;
4744      if ($line =~ s/^((?:notest|f?force)\s*)//) {
4745          $pos -= length($1);
4746      }
4747      my @return;
4748      if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4749          @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4750      } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4751          @return = ();
4752      } elsif ($line =~ /^(a|ls)\s/) {
4753          @return = cplx('CPAN::Author',uc($word));
4754      } elsif ($line =~ /^b\s/) {
4755          CPAN::Shell->local_bundles;
4756          @return = cplx('CPAN::Bundle',$word);
4757      } elsif ($line =~ /^d\s/) {
4758          @return = cplx('CPAN::Distribution',$word);
4759      } elsif ($line =~ m/^(
4760                            [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4761                           )\s/x ) {
4762          if ($word =~ /^Bundle::/) {
4763              CPAN::Shell->local_bundles;
4764          }
4765          @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4766      } elsif ($line =~ /^i\s/) {
4767          @return = cpl_any($word);
4768      } elsif ($line =~ /^reload\s/) {
4769          @return = cpl_reload($word,$line,$pos);
4770      } elsif ($line =~ /^o\s/) {
4771          @return = cpl_option($word,$line,$pos);
4772      } elsif ($line =~ m/^\S+\s/ ) {
4773          # fallback for future commands and what we have forgotten above
4774          @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4775      } else {
4776          @return = ();
4777      }
4778      return @return;
4779  }
4780  
4781  #-> sub CPAN::Complete::cplx ;
4782  sub cplx {
4783      my($class, $word) = @_;
4784      if (CPAN::_sqlite_running) {
4785          $CPAN::SQLite->search($class, "^\Q$word\E");
4786      }
4787      sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4788  }
4789  
4790  #-> sub CPAN::Complete::cpl_any ;
4791  sub cpl_any {
4792      my($word) = shift;
4793      return (
4794              cplx('CPAN::Author',$word),
4795              cplx('CPAN::Bundle',$word),
4796              cplx('CPAN::Distribution',$word),
4797              cplx('CPAN::Module',$word),
4798             );
4799  }
4800  
4801  #-> sub CPAN::Complete::cpl_reload ;
4802  sub cpl_reload {
4803      my($word,$line,$pos) = @_;
4804      $word ||= "";
4805      my(@words) = split " ", $line;
4806      CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4807      my(@ok) = qw(cpan index);
4808      return @ok if @words == 1;
4809      return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4810  }
4811  
4812  #-> sub CPAN::Complete::cpl_option ;
4813  sub cpl_option {
4814      my($word,$line,$pos) = @_;
4815      $word ||= "";
4816      my(@words) = split " ", $line;
4817      CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4818      my(@ok) = qw(conf debug);
4819      return @ok if @words == 1;
4820      return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4821      if (0) {
4822      } elsif ($words[1] eq 'index') {
4823          return ();
4824      } elsif ($words[1] eq 'conf') {
4825          return CPAN::HandleConfig::cpl(@_);
4826      } elsif ($words[1] eq 'debug') {
4827          return sort grep /^\Q$word\E/i,
4828              sort keys %CPAN::DEBUG, 'all';
4829      }
4830  }
4831  
4832  package CPAN::Index;
4833  use strict;
4834  
4835  #-> sub CPAN::Index::force_reload ;
4836  sub force_reload {
4837      my($class) = @_;
4838      $CPAN::Index::LAST_TIME = 0;
4839      $class->reload(1);
4840  }
4841  
4842  #-> sub CPAN::Index::reload ;
4843  sub reload {
4844      my($self,$force) = @_;
4845      my $time = time;
4846  
4847      # XXX check if a newer one is available. (We currently read it
4848      # from time to time)
4849      for ($CPAN::Config->{index_expire}) {
4850          $_ = 0.001 unless $_ && $_ > 0.001;
4851      }
4852      unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4853          # debug here when CPAN doesn't seem to read the Metadata
4854          require Carp;
4855          Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4856      }
4857      unless ($CPAN::META->{PROTOCOL}) {
4858          $self->read_metadata_cache;
4859          $CPAN::META->{PROTOCOL} ||= "1.0";
4860      }
4861      if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4862          # warn "Setting last_time to 0";
4863          $LAST_TIME = 0; # No warning necessary
4864      }
4865      if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4866          and ! $force) {
4867          # called too often
4868          # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4869      } elsif (0) {
4870          # IFF we are developing, it helps to wipe out the memory
4871          # between reloads, otherwise it is not what a user expects.
4872          undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4873          $CPAN::META = CPAN->new;
4874      } else {
4875          my($debug,$t2);
4876          local $LAST_TIME = $time;
4877          local $CPAN::META->{PROTOCOL} = PROTOCOL;
4878  
4879          my $needshort = $^O eq "dos";
4880  
4881          $self->rd_authindex($self
4882                            ->reload_x(
4883                                       "authors/01mailrc.txt.gz",
4884                                       $needshort ?
4885                                       File::Spec->catfile('authors', '01mailrc.gz') :
4886                                       File::Spec->catfile('authors', '01mailrc.txt.gz'),
4887                                       $force));
4888          $t2 = time;
4889          $debug = "timing reading 01[".($t2 - $time)."]";
4890          $time = $t2;
4891          return if $CPAN::Signal; # this is sometimes lengthy
4892          $self->rd_modpacks($self
4893                           ->reload_x(
4894                                      "modules/02packages.details.txt.gz",
4895                                      $needshort ?
4896                                      File::Spec->catfile('modules', '02packag.gz') :
4897                                      File::Spec->catfile('modules', '02packages.details.txt.gz'),
4898                                      $force));
4899          $t2 = time;
4900          $debug .= "02[".($t2 - $time)."]";
4901          $time = $t2;
4902          return if $CPAN::Signal; # this is sometimes lengthy
4903          $self->rd_modlist($self
4904                          ->reload_x(
4905                                     "modules/03modlist.data.gz",
4906                                     $needshort ?
4907                                     File::Spec->catfile('modules', '03mlist.gz') :
4908                                     File::Spec->catfile('modules', '03modlist.data.gz'),
4909                                     $force));
4910          $self->write_metadata_cache;
4911          $t2 = time;
4912          $debug .= "03[".($t2 - $time)."]";
4913          $time = $t2;
4914          CPAN->debug($debug) if $CPAN::DEBUG;
4915      }
4916      if ($CPAN::Config->{build_dir_reuse}) {
4917          $self->reanimate_build_dir;
4918      }
4919      if (CPAN::_sqlite_running) {
4920          $CPAN::SQLite->reload(time => $time, force => $force)
4921              if not $LAST_TIME;
4922      }
4923      $LAST_TIME = $time;
4924      $CPAN::META->{PROTOCOL} = PROTOCOL;
4925  }
4926  
4927  #-> sub CPAN::Index::reanimate_build_dir ;
4928  sub reanimate_build_dir {
4929      my($self) = @_;
4930      unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4931          return;
4932      }
4933      return if $HAVE_REANIMATED++;
4934      my $d = $CPAN::Config->{build_dir};
4935      my $dh = DirHandle->new;
4936      opendir $dh, $d or return; # does not exist
4937      my $dirent;
4938      my $i = 0;
4939      my $painted = 0;
4940      my $restored = 0;
4941      $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4942      my @candidates = map { $_->[0] }
4943          sort { $b->[1] <=> $a->[1] }
4944              map { [ $_, -M File::Spec->catfile($d,$_) ] }
4945                  grep {/\.yml$/} readdir $dh;
4946    DISTRO: for $i (0..$#candidates) {
4947          my $dirent = $candidates[$i];
4948          my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4949          if ($@) {
4950              warn "Error while parsing file '$dirent'; error: '$@'";
4951              next DISTRO;
4952          }
4953          my $c = $y->[0];
4954          if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4955              my $key = $c->{distribution}{ID};
4956              for my $k (keys %{$c->{distribution}}) {
4957                  if ($c->{distribution}{$k}
4958                      && ref $c->{distribution}{$k}
4959                      && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4960                      $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4961                  }
4962              }
4963  
4964              #we tried to restore only if element already
4965              #exists; but then we do not work with metadata
4966              #turned off.
4967              my $do
4968                  = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4969                      = $c->{distribution};
4970              for my $skipper (qw(
4971                                  badtestcnt
4972                                  configure_requires_later
4973                                  configure_requires_later_for
4974                                  force_update
4975                                  later
4976                                  later_for
4977                                  notest
4978                                  should_report
4979                                  sponsored_mods
4980                                 )) {
4981                  delete $do->{$skipper};
4982              }
4983              # $DB::single = 1;
4984              if ($do->{make_test}
4985                  && $do->{build_dir}
4986                  && !(UNIVERSAL::can($do->{make_test},"failed") ?
4987                       $do->{make_test}->failed :
4988                       $do->{make_test} =~ /^YES/
4989                      )
4990                  && (
4991                      !$do->{install}
4992                      ||
4993                      $do->{install}->failed
4994                     )
4995                 ) {
4996                  $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4997              }
4998              $restored++;
4999          }
5000          $i++;
5001          while (($painted/76) < ($i/@candidates)) {
5002              $CPAN::Frontend->myprint(".");
5003              $painted++;
5004          }
5005      }
5006      $CPAN::Frontend->myprint(sprintf(
5007                                       "DONE\nFound %s old build%s, restored the state of %s\n",
5008                                       @candidates ? sprintf("%d",scalar @candidates) : "no",
5009                                       @candidates==1 ? "" : "s",
5010                                       $restored || "none",
5011                                      ));
5012  }
5013  
5014  
5015  #-> sub CPAN::Index::reload_x ;
5016  sub reload_x {
5017      my($cl,$wanted,$localname,$force) = @_;
5018      $force |= 2; # means we're dealing with an index here
5019      CPAN::HandleConfig->load; # we should guarantee loading wherever
5020                                # we rely on Config XXX
5021      $localname ||= $wanted;
5022      my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5023                                           $localname);
5024      if (
5025          -f $abs_wanted &&
5026          -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5027          !($force & 1)
5028         ) {
5029          my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5030          $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5031                     qq{day$s. I\'ll use that.});
5032          return $abs_wanted;
5033      } else {
5034          $force |= 1; # means we're quite serious about it.
5035      }
5036      return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5037  }
5038  
5039  #-> sub CPAN::Index::rd_authindex ;
5040  sub rd_authindex {
5041      my($cl, $index_target) = @_;
5042      return unless defined $index_target;
5043      return if CPAN::_sqlite_running;
5044      my @lines;
5045      $CPAN::Frontend->myprint("Going to read $index_target\n");
5046      local(*FH);
5047      tie *FH, 'CPAN::Tarzip', $index_target;
5048      local($/) = "\n";
5049      local($_);
5050      push @lines, split /\012/ while <FH>;
5051      my $i = 0;
5052      my $painted = 0;
5053      foreach (@lines) {
5054          my($userid,$fullname,$email) =
5055              m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5056          $fullname ||= $email;
5057          if ($userid && $fullname && $email) {
5058              my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5059              $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5060          } else {
5061              CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5062          }
5063          $i++;
5064          while (($painted/76) < ($i/@lines)) {
5065              $CPAN::Frontend->myprint(".");
5066              $painted++;
5067          }
5068          return if $CPAN::Signal;
5069      }
5070      $CPAN::Frontend->myprint("DONE\n");
5071  }
5072  
5073  sub userid {
5074    my($self,$dist) = @_;
5075    $dist = $self->{'id'} unless defined $dist;
5076    my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5077    $ret;
5078  }
5079  
5080  #-> sub CPAN::Index::rd_modpacks ;
5081  sub rd_modpacks {
5082      my($self, $index_target) = @_;
5083      return unless defined $index_target;
5084      return if CPAN::_sqlite_running;
5085      $CPAN::Frontend->myprint("Going to read $index_target\n");
5086      my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5087      local $_;
5088      CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5089      my $slurp = "";
5090      my $chunk;
5091      while (my $bytes = $fh->READ(\$chunk,8192)) {
5092          $slurp.=$chunk;
5093      }
5094      my @lines = split /\012/, $slurp;
5095      CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5096      undef $fh;
5097      # read header
5098      my($line_count,$last_updated);
5099      while (@lines) {
5100          my $shift = shift(@lines);
5101          last if $shift =~ /^\s*$/;
5102          $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5103          $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5104      }
5105      CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5106      if (not defined $line_count) {
5107  
5108          $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5109  Please check the validity of the index file by comparing it to more
5110  than one CPAN mirror. I'll continue but problems seem likely to
5111  happen.\a
5112  });
5113  
5114          $CPAN::Frontend->mysleep(5);
5115      } elsif ($line_count != scalar @lines) {
5116  
5117          $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5118  contains a Line-Count header of %d but I see %d lines there. Please
5119  check the validity of the index file by comparing it to more than one
5120  CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5121  $index_target, $line_count, scalar(@lines));
5122  
5123      }
5124      if (not defined $last_updated) {
5125  
5126          $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5127  Please check the validity of the index file by comparing it to more
5128  than one CPAN mirror. I'll continue but problems seem likely to
5129  happen.\a
5130  });
5131  
5132          $CPAN::Frontend->mysleep(5);
5133      } else {
5134  
5135          $CPAN::Frontend
5136              ->myprint(sprintf qq{  Database was generated on %s\n},
5137                        $last_updated);
5138          $DATE_OF_02 = $last_updated;
5139  
5140          my $age = time;
5141          if ($CPAN::META->has_inst('HTTP::Date')) {
5142              require HTTP::Date;
5143              $age -= HTTP::Date::str2time($last_updated);
5144          } else {
5145              $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5146              require Time::Local;
5147              my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5148              $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5149              $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5150          }
5151          $age /= 3600*24;
5152          if ($age > 30) {
5153  
5154              $CPAN::Frontend
5155                  ->mywarn(sprintf
5156                           qq{Warning: This index file is %d days old.
5157    Please check the host you chose as your CPAN mirror for staleness.
5158    I'll continue but problems seem likely to happen.\a\n},
5159                           $age);
5160  
5161          } elsif ($age < -1) {
5162  
5163              $CPAN::Frontend
5164                  ->mywarn(sprintf
5165                           qq{Warning: Your system date is %d days behind this index file!
5166    System time:          %s
5167    Timestamp index file: %s
5168    Please fix your system time, problems with the make command expected.\n},
5169                           -$age,
5170                           scalar gmtime,
5171                           $DATE_OF_02,
5172                          );
5173  
5174          }
5175      }
5176  
5177  
5178      # A necessity since we have metadata_cache: delete what isn't
5179      # there anymore
5180      my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5181      CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5182      my(%exists);
5183      my $i = 0;
5184      my $painted = 0;
5185      foreach (@lines) {
5186          # before 1.56 we split into 3 and discarded the rest. From
5187          # 1.57 we assign remaining text to $comment thus allowing to
5188          # influence isa_perl
5189          my($mod,$version,$dist,$comment) = split " ", $_, 4;
5190          my($bundle,$id,$userid);
5191  
5192          if ($mod eq 'CPAN' &&
5193              ! (
5194              CPAN::Queue->exists('Bundle::CPAN') ||
5195              CPAN::Queue->exists('CPAN')
5196              )
5197          ) {
5198              local($^W)= 0;
5199              if ($version > $CPAN::VERSION) {
5200                  $CPAN::Frontend->mywarn(qq{
5201    New CPAN.pm version (v$version) available.
5202    [Currently running version is v$CPAN::VERSION]
5203    You might want to try
5204      install CPAN
5205      reload cpan
5206    to both upgrade CPAN.pm and run the new version without leaving
5207    the current session.
5208  
5209  }); #});
5210                  $CPAN::Frontend->mysleep(2);
5211                  $CPAN::Frontend->myprint(qq{\n});
5212              }
5213              last if $CPAN::Signal;
5214          } elsif ($mod =~ /^Bundle::(.*)/) {
5215              $bundle = $1;
5216          }
5217  
5218          if ($bundle) {
5219              $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5220              # Let's make it a module too, because bundles have so much
5221              # in common with modules.
5222  
5223              # Changed in 1.57_63: seems like memory bloat now without
5224              # any value, so commented out
5225  
5226              # $CPAN::META->instance('CPAN::Module',$mod);
5227  
5228          } else {
5229  
5230              # instantiate a module object
5231              $id = $CPAN::META->instance('CPAN::Module',$mod);
5232  
5233          }
5234  
5235          # Although CPAN prohibits same name with different version the
5236          # indexer may have changed the version for the same distro
5237          # since the last time ("Force Reindexing" feature)
5238          if ($id->cpan_file ne $dist
5239              ||
5240              $id->cpan_version ne $version
5241             ) {
5242              $userid = $id->userid || $self->userid($dist);
5243              $id->set(
5244                       'CPAN_USERID' => $userid,
5245                       'CPAN_VERSION' => $version,
5246                       'CPAN_FILE' => $dist,
5247                      );
5248          }
5249  
5250          # instantiate a distribution object
5251          if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5252          # we do not need CONTAINSMODS unless we do something with
5253          # this dist, so we better produce it on demand.
5254  
5255          ## my $obj = $CPAN::META->instance(
5256          ##                                 'CPAN::Distribution' => $dist
5257          ##                                );
5258          ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5259          } else {
5260              $CPAN::META->instance(
5261                                    'CPAN::Distribution' => $dist
5262                                   )->set(
5263                                          'CPAN_USERID' => $userid,
5264                                          'CPAN_COMMENT' => $comment,
5265                                         );
5266          }
5267          if ($secondtime) {
5268              for my $name ($mod,$dist) {
5269                  # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5270                  $exists{$name} = undef;
5271              }
5272          }
5273          $i++;
5274          while (($painted/76) < ($i/@lines)) {
5275              $CPAN::Frontend->myprint(".");
5276              $painted++;
5277          }
5278          return if $CPAN::Signal;
5279      }
5280      $CPAN::Frontend->myprint("DONE\n");
5281      if ($secondtime) {
5282          for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5283              for my $o ($CPAN::META->all_objects($class)) {
5284                  next if exists $exists{$o->{ID}};
5285                  $CPAN::META->delete($class,$o->{ID});
5286                  # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5287                  #     if $CPAN::DEBUG;
5288              }
5289          }
5290      }
5291  }
5292  
5293  #-> sub CPAN::Index::rd_modlist ;
5294  sub rd_modlist {
5295      my($cl,$index_target) = @_;
5296      return unless defined $index_target;
5297      return if CPAN::_sqlite_running;
5298      $CPAN::Frontend->myprint("Going to read $index_target\n");
5299      my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5300      local $_;
5301      my $slurp = "";
5302      my $chunk;
5303      while (my $bytes = $fh->READ(\$chunk,8192)) {
5304          $slurp.=$chunk;
5305      }
5306      my @eval2 = split /\012/, $slurp;
5307  
5308      while (@eval2) {
5309          my $shift = shift(@eval2);
5310          if ($shift =~ /^Date:\s+(.*)/) {
5311              if ($DATE_OF_03 eq $1) {
5312                  $CPAN::Frontend->myprint("Unchanged.\n");
5313                  return;
5314              }
5315              ($DATE_OF_03) = $1;
5316          }
5317          last if $shift =~ /^\s*$/;
5318      }
5319      push @eval2, q{CPAN::Modulelist->data;};
5320      local($^W) = 0;
5321      my($comp) = Safe->new("CPAN::Safe1");
5322      my($eval2) = join("\n", @eval2);
5323      CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5324      my $ret = $comp->reval($eval2);
5325      Carp::confess($@) if $@;
5326      return if $CPAN::Signal;
5327      my $i = 0;
5328      my $until = keys(%$ret);
5329      my $painted = 0;
5330      CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5331      for (keys %$ret) {
5332          my $obj = $CPAN::META->instance("CPAN::Module",$_);
5333          delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5334          $obj->set(%{$ret->{$_}});
5335          $i++;
5336          while (($painted/76) < ($i/$until)) {
5337              $CPAN::Frontend->myprint(".");
5338              $painted++;
5339          }
5340          return if $CPAN::Signal;
5341      }
5342      $CPAN::Frontend->myprint("DONE\n");
5343  }
5344  
5345  #-> sub CPAN::Index::write_metadata_cache ;
5346  sub write_metadata_cache {
5347      my($self) = @_;
5348      return unless $CPAN::Config->{'cache_metadata'};
5349      return if CPAN::_sqlite_running;
5350      return unless $CPAN::META->has_usable("Storable");
5351      my $cache;
5352      foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5353                        CPAN::Distribution)) {
5354          $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5355      }
5356      my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5357      $cache->{last_time} = $LAST_TIME;
5358      $cache->{DATE_OF_02} = $DATE_OF_02;
5359      $cache->{PROTOCOL} = PROTOCOL;
5360      $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5361      eval { Storable::nstore($cache, $metadata_file) };
5362      $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5363  }
5364  
5365  #-> sub CPAN::Index::read_metadata_cache ;
5366  sub read_metadata_cache {
5367      my($self) = @_;
5368      return unless $CPAN::Config->{'cache_metadata'};
5369      return if CPAN::_sqlite_running;
5370      return unless $CPAN::META->has_usable("Storable");
5371      my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5372      return unless -r $metadata_file and -f $metadata_file;
5373      $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5374      my $cache;
5375      eval { $cache = Storable::retrieve($metadata_file) };
5376      $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5377      if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5378          $LAST_TIME = 0;
5379          return;
5380      }
5381      if (exists $cache->{PROTOCOL}) {
5382          if (PROTOCOL > $cache->{PROTOCOL}) {
5383              $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5384                                              "with protocol v%s, requiring v%s\n",
5385                                              $cache->{PROTOCOL},
5386                                              PROTOCOL)
5387                                     );
5388              return;
5389          }
5390      } else {
5391          $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5392                                  "with protocol v1.0\n");
5393          return;
5394      }
5395      my $clcnt = 0;
5396      my $idcnt = 0;
5397      while(my($class,$v) = each %$cache) {
5398          next unless $class =~ /^CPAN::/;
5399          $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5400          while (my($id,$ro) = each %$v) {
5401              $CPAN::META->{readwrite}{$class}{$id} ||=
5402                  $class->new(ID=>$id, RO=>$ro);
5403              $idcnt++;
5404          }
5405          $clcnt++;
5406      }
5407      unless ($clcnt) { # sanity check
5408          $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5409          return;
5410      }
5411      if ($idcnt < 1000) {
5412          $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5413                                   "in $metadata_file\n");
5414          return;
5415      }
5416      $CPAN::META->{PROTOCOL} ||=
5417          $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5418                              # does initialize to some protocol
5419      $LAST_TIME = $cache->{last_time};
5420      $DATE_OF_02 = $cache->{DATE_OF_02};
5421      $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5422          if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5423      return;
5424  }
5425  
5426  package CPAN::InfoObj;
5427  use strict;
5428  
5429  sub ro {
5430      my $self = shift;
5431      exists $self->{RO} and return $self->{RO};
5432  }
5433  
5434  #-> sub CPAN::InfoObj::cpan_userid
5435  sub cpan_userid {
5436      my $self = shift;
5437      my $ro = $self->ro;
5438      if ($ro) {
5439          return $ro->{CPAN_USERID} || "N/A";
5440      } else {
5441          $self->debug("ID[$self->{ID}]");
5442          # N/A for bundles found locally
5443          return "N/A";
5444      }
5445  }
5446  
5447  sub id { shift->{ID}; }
5448  
5449  #-> sub CPAN::InfoObj::new ;
5450  sub new {
5451      my $this = bless {}, shift;
5452      %$this = @_;
5453      $this
5454  }
5455  
5456  # The set method may only be used by code that reads index data or
5457  # otherwise "objective" data from the outside world. All session
5458  # related material may do anything else with instance variables but
5459  # must not touch the hash under the RO attribute. The reason is that
5460  # the RO hash gets written to Metadata file and is thus persistent.
5461  
5462  #-> sub CPAN::InfoObj::safe_chdir ;
5463  sub safe_chdir {
5464    my($self,$todir) = @_;
5465    # we die if we cannot chdir and we are debuggable
5466    Carp::confess("safe_chdir called without todir argument")
5467          unless defined $todir and length $todir;
5468    if (chdir $todir) {
5469      $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5470          if $CPAN::DEBUG;
5471    } else {
5472      if (-e $todir) {
5473          unless (-x $todir) {
5474              unless (chmod 0755, $todir) {
5475                  my $cwd = CPAN::anycwd();
5476                  $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5477                                          "permission to change the permission; cannot ".
5478                                          "chdir to '$todir'\n");
5479                  $CPAN::Frontend->mysleep(5);
5480                  $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5481                                         qq{to todir[$todir]: $!});
5482              }
5483          }
5484      } else {
5485          $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5486      }
5487      if (chdir $todir) {
5488        $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5489            if $CPAN::DEBUG;
5490      } else {
5491        my $cwd = CPAN::anycwd();
5492        $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5493                               qq{to todir[$todir] (a chmod has been issued): $!});
5494      }
5495    }
5496  }
5497  
5498  #-> sub CPAN::InfoObj::set ;
5499  sub set {
5500      my($self,%att) = @_;
5501      my $class = ref $self;
5502  
5503      # This must be ||=, not ||, because only if we write an empty
5504      # reference, only then the set method will write into the readonly
5505      # area. But for Distributions that spring into existence, maybe
5506      # because of a typo, we do not like it that they are written into
5507      # the readonly area and made permanent (at least for a while) and
5508      # that is why we do not "allow" other places to call ->set.
5509      unless ($self->id) {
5510          CPAN->debug("Bug? Empty ID, rejecting");
5511          return;
5512      }
5513      my $ro = $self->{RO} =
5514          $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5515  
5516      while (my($k,$v) = each %att) {
5517          $ro->{$k} = $v;
5518      }
5519  }
5520  
5521  #-> sub CPAN::InfoObj::as_glimpse ;
5522  sub as_glimpse {
5523      my($self) = @_;
5524      my(@m);
5525      my $class = ref($self);
5526      $class =~ s/^CPAN:://;
5527      my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5528      push @m, sprintf "%-15s %s\n", $class, $id;
5529      join "", @m;
5530  }
5531  
5532  #-> sub CPAN::InfoObj::as_string ;
5533  sub as_string {
5534      my($self) = @_;
5535      my(@m);
5536      my $class = ref($self);
5537      $class =~ s/^CPAN:://;
5538      push @m, $class, " id = $self->{ID}\n";
5539      my $ro;
5540      unless ($ro = $self->ro) {
5541          if (substr($self->{ID},-1,1) eq ".") { # directory
5542              $ro = +{};
5543          } else {
5544              $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5545              $CPAN::Frontend->mysleep(5);
5546              return;
5547          }
5548      }
5549      for (sort keys %$ro) {
5550          # next if m/^(ID|RO)$/;
5551          my $extra = "";
5552          if ($_ eq "CPAN_USERID") {
5553              $extra .= " (";
5554              $extra .= $self->fullname;
5555              my $email; # old perls!
5556              if ($email = $CPAN::META->instance("CPAN::Author",
5557                                                 $self->cpan_userid
5558                                                )->email) {
5559                  $extra .= " <$email>";
5560              } else {
5561                  $extra .= " <no email>";
5562              }
5563              $extra .= ")";
5564          } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5565              push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5566              next;
5567          }
5568          next unless defined $ro->{$_};
5569          push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5570      }
5571    KEY: for (sort keys %$self) {
5572          next if m/^(ID|RO)$/;
5573          unless (defined $self->{$_}) {
5574              delete $self->{$_};
5575              next KEY;
5576          }
5577          if (ref($self->{$_}) eq "ARRAY") {
5578              push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5579          } elsif (ref($self->{$_}) eq "HASH") {
5580              my $value;
5581              if (/^CONTAINSMODS$/) {
5582                  $value = join(" ",sort keys %{$self->{$_}});
5583              } elsif (/^prereq_pm$/) {
5584                  my @value;
5585                  my $v = $self->{$_};
5586                  for my $x (sort keys %$v) {
5587                      my @svalue;
5588                      for my $y (sort keys %{$v->{$x}}) {
5589                          push @svalue, "$y=>$v->{$x}{$y}";
5590                      }
5591                      push @value, "$x\:" . join ",", @svalue if @svalue;
5592                  }
5593                  $value = join ";", @value;
5594              } else {
5595                  $value = $self->{$_};
5596              }
5597              push @m, sprintf(
5598                               "    %-12s %s\n",
5599                               $_,
5600                               $value,
5601                              );
5602          } else {
5603              push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5604          }
5605      }
5606      join "", @m, "\n";
5607  }
5608  
5609  #-> sub CPAN::InfoObj::fullname ;
5610  sub fullname {
5611      my($self) = @_;
5612      $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5613  }
5614  
5615  #-> sub CPAN::InfoObj::dump ;
5616  sub dump {
5617      my($self, $what) = @_;
5618      unless ($CPAN::META->has_inst("Data::Dumper")) {
5619          $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5620      }
5621      local $Data::Dumper::Sortkeys;
5622      $Data::Dumper::Sortkeys = 1;
5623      my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5624      if (length $out > 100000) {
5625          my $fh_pager = FileHandle->new;
5626          local($SIG{PIPE}) = "IGNORE";
5627          my $pager = $CPAN::Config->{'pager'} || "cat";
5628          $fh_pager->open("|$pager")
5629              or die "Could not open pager $pager\: $!";
5630          $fh_pager->print($out);
5631          close $fh_pager;
5632      } else {
5633          $CPAN::Frontend->myprint($out);
5634      }
5635  }
5636  
5637  package CPAN::Author;
5638  use strict;
5639  
5640  #-> sub CPAN::Author::force
5641  sub force {
5642      my $self = shift;
5643      $self->{force}++;
5644  }
5645  
5646  #-> sub CPAN::Author::force
5647  sub unforce {
5648      my $self = shift;
5649      delete $self->{force};
5650  }
5651  
5652  #-> sub CPAN::Author::id
5653  sub id {
5654      my $self = shift;
5655      my $id = $self->{ID};
5656      $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5657      $id;
5658  }
5659  
5660  #-> sub CPAN::Author::as_glimpse ;
5661  sub as_glimpse {
5662      my($self) = @_;
5663      my(@m);
5664      my $class = ref($self);
5665      $class =~ s/^CPAN:://;
5666      push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5667                       $class,
5668                       $self->{ID},
5669                       $self->fullname,
5670                       $self->email);
5671      join "", @m;
5672  }
5673  
5674  #-> sub CPAN::Author::fullname ;
5675  sub fullname {
5676      shift->ro->{FULLNAME};
5677  }
5678  *name = \&fullname;
5679  
5680  #-> sub CPAN::Author::email ;
5681  sub email    { shift->ro->{EMAIL}; }
5682  
5683  #-> sub CPAN::Author::ls ;
5684  sub ls {
5685      my $self = shift;
5686      my $glob = shift || "";
5687      my $silent = shift || 0;
5688      my $id = $self->id;
5689  
5690      # adapted from CPAN::Distribution::verifyCHECKSUM ;
5691      my(@csf); # chksumfile
5692      @csf = $self->id =~ /(.)(.)(.*)/;
5693      $csf[1] = join "", @csf[0,1];
5694      $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5695      my(@dl);
5696      @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5697      unless (grep {$_->[2] eq $csf[1]} @dl) {
5698          $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5699          return;
5700      }
5701      @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5702      unless (grep {$_->[2] eq $csf[2]} @dl) {
5703          $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5704          return;
5705      }
5706      @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5707      if ($glob) {
5708          if ($CPAN::META->has_inst("Text::Glob")) {
5709              my $rglob = Text::Glob::glob_to_regex($glob);
5710              @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5711          } else {
5712              $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5713          }
5714      }
5715      unless ($silent >= 2) {
5716          $CPAN::Frontend->myprint(join "", map {
5717              sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5718          } sort { $a->[2] cmp $b->[2] } @dl);
5719      }
5720      @dl;
5721  }
5722  
5723  # returns an array of arrays, the latter contain (size,mtime,filename)
5724  #-> sub CPAN::Author::dir_listing ;
5725  sub dir_listing {
5726      my $self = shift;
5727      my $chksumfile = shift;
5728      my $recursive = shift;
5729      my $may_ftp = shift;
5730  
5731      my $lc_want =
5732          File::Spec->catfile($CPAN::Config->{keep_source_where},
5733                              "authors", "id", @$chksumfile);
5734  
5735      my $fh;
5736  
5737      # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5738      # hazard.  (Without GPG installed they are not that much better,
5739      # though.)
5740      $fh = FileHandle->new;
5741      if (open($fh, $lc_want)) {
5742          my $line = <$fh>; close $fh;
5743          unlink($lc_want) unless $line =~ /PGP/;
5744      }
5745  
5746      local($") = "/";
5747      # connect "force" argument with "index_expire".
5748      my $force = $self->{force};
5749      if (my @stat = stat $lc_want) {
5750          $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5751      }
5752      my $lc_file;
5753      if ($may_ftp) {
5754          $lc_file = CPAN::FTP->localize(
5755                                         "authors/id/@$chksumfile",
5756                                         $lc_want,
5757                                         $force,
5758                                        );
5759          unless ($lc_file) {
5760              $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5761              $chksumfile->[-1] .= ".gz";
5762              $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5763                                             "$lc_want.gz",1);
5764              if ($lc_file) {
5765                  $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5766                  eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5767              } else {
5768                  return;
5769              }
5770          }
5771      } else {
5772          $lc_file = $lc_want;
5773          # we *could* second-guess and if the user has a file: URL,
5774          # then we could look there. But on the other hand, if they do
5775          # have a file: URL, wy did they choose to set
5776          # $CPAN::Config->{show_upload_date} to false?
5777      }
5778  
5779      # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5780      $fh = FileHandle->new;
5781      my($cksum);
5782      if (open $fh, $lc_file) {
5783          local($/);
5784          my $eval = <$fh>;
5785          $eval =~ s/\015?\012/\n/g;
5786          close $fh;
5787          my($comp) = Safe->new();
5788          $cksum = $comp->reval($eval);
5789          if ($@) {
5790              rename $lc_file, "$lc_file.bad";
5791              Carp::confess($@) if $@;
5792          }
5793      } elsif ($may_ftp) {
5794          Carp::carp "Could not open '$lc_file' for reading.";
5795      } else {
5796          # Maybe should warn: "You may want to set show_upload_date to a true value"
5797          return;
5798      }
5799      my(@result,$f);
5800      for $f (sort keys %$cksum) {
5801          if (exists $cksum->{$f}{isdir}) {
5802              if ($recursive) {
5803                  my(@dir) = @$chksumfile;
5804                  pop @dir;
5805                  push @dir, $f, "CHECKSUMS";
5806                  push @result, map {
5807                      [$_->[0], $_->[1], "$f/$_->[2]"]
5808                  } $self->dir_listing(\@dir,1,$may_ftp);
5809              } else {
5810                  push @result, [ 0, "-", $f ];
5811              }
5812          } else {
5813              push @result, [
5814                             ($cksum->{$f}{"size"}||0),
5815                             $cksum->{$f}{"mtime"}||"---",
5816                             $f
5817                            ];
5818          }
5819      }
5820      @result;
5821  }
5822  
5823  #-> sub CPAN::Author::reports
5824  sub reports {
5825      $CPAN::Frontend->mywarn("reports on authors not implemented.
5826  Please file a bugreport if you need this.\n");
5827  }
5828  
5829  package CPAN::Distribution;
5830  use strict;
5831  
5832  # Accessors
5833  sub cpan_comment {
5834      my $self = shift;
5835      my $ro = $self->ro or return;
5836      $ro->{CPAN_COMMENT}
5837  }
5838  
5839  #-> CPAN::Distribution::undelay
5840  sub undelay {
5841      my $self = shift;
5842      for my $delayer (
5843                       "configure_requires_later",
5844                       "configure_requires_later_for",
5845                       "later",
5846                       "later_for",
5847                      ) {
5848          delete $self->{$delayer};
5849      }
5850  }
5851  
5852  #-> CPAN::Distribution::is_dot_dist
5853  sub is_dot_dist {
5854      my($self) = @_;
5855      return substr($self->id,-1,1) eq ".";
5856  }
5857  
5858  # add the A/AN/ stuff
5859  #-> CPAN::Distribution::normalize
5860  sub normalize {
5861      my($self,$s) = @_;
5862      $s = $self->id unless defined $s;
5863      if (substr($s,-1,1) eq ".") {
5864          # using a global because we are sometimes called as static method
5865          if (!$CPAN::META->{LOCK}
5866              && !$CPAN::Have_warned->{"$s is unlocked"}++
5867             ) {
5868              $CPAN::Frontend->mywarn("You are visiting the local directory
5869    '$s'
5870    without lock, take care that concurrent processes do not do likewise.\n");
5871              $CPAN::Frontend->mysleep(1);
5872          }
5873          if ($s eq ".") {
5874              $s = "$CPAN::iCwd/.";
5875          } elsif (File::Spec->file_name_is_absolute($s)) {
5876          } elsif (File::Spec->can("rel2abs")) {
5877              $s = File::Spec->rel2abs($s);
5878          } else {
5879              $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5880          }
5881          CPAN->debug("s[$s]") if $CPAN::DEBUG;
5882          unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5883              for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5884                  $_->{build_dir} = $s;
5885                  $_->{archived} = "local_directory";
5886                  $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5887              }
5888          }
5889      } elsif (
5890          $s =~ tr|/|| == 1
5891          or
5892          $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5893         ) {
5894          return $s if $s =~ m:^N/A|^Contact Author: ;
5895          $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5896              $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5897          CPAN->debug("s[$s]") if $CPAN::DEBUG;
5898      }
5899      $s;
5900  }
5901  
5902  #-> sub CPAN::Distribution::author ;
5903  sub author {
5904      my($self) = @_;
5905      my($authorid);
5906      if (substr($self->id,-1,1) eq ".") {
5907          $authorid = "LOCAL";
5908      } else {
5909          ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5910      }
5911      CPAN::Shell->expand("Author",$authorid);
5912  }
5913  
5914  # tries to get the yaml from CPAN instead of the distro itself:
5915  # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5916  sub fast_yaml {
5917      my($self) = @_;
5918      my $meta = $self->pretty_id;
5919      $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5920      my(@ls) = CPAN::Shell->globls($meta);
5921      my $norm = $self->normalize($meta);
5922  
5923      my($local_file);
5924      my($local_wanted) =
5925          File::Spec->catfile(
5926                              $CPAN::Config->{keep_source_where},
5927                              "authors",
5928                              "id",
5929                              split(/\//,$norm)
5930                             );
5931      $self->debug("Doing localize") if $CPAN::DEBUG;
5932      unless ($local_file =
5933              CPAN::FTP->localize("authors/id/$norm",
5934                                  $local_wanted)) {
5935          $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5936      }
5937      my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5938  }
5939  
5940  #-> sub CPAN::Distribution::cpan_userid
5941  sub cpan_userid {
5942      my $self = shift;
5943      if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5944          return $1;
5945      }
5946      return $self->SUPER::cpan_userid;
5947  }
5948  
5949  #-> sub CPAN::Distribution::pretty_id
5950  sub pretty_id {
5951      my $self = shift;
5952      my $id = $self->id;
5953      return $id unless $id =~ m|^./../|;
5954      substr($id,5);
5955  }
5956  
5957  #-> sub CPAN::Distribution::base_id
5958  sub base_id {
5959      my $self = shift;
5960      my $id = $self->pretty_id();
5961      my $base_id = File::Basename::basename($id);
5962      $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5963      return $base_id;
5964  }
5965  
5966  # mark as dirty/clean for the sake of recursion detection. $color=1
5967  # means "in use", $color=0 means "not in use anymore". $color=2 means
5968  # we have determined prereqs now and thus insist on passing this
5969  # through (at least) once again.
5970  
5971  #-> sub CPAN::Distribution::color_cmd_tmps ;
5972  sub color_cmd_tmps {
5973      my($self) = shift;
5974      my($depth) = shift || 0;
5975      my($color) = shift || 0;
5976      my($ancestors) = shift || [];
5977      # a distribution needs to recurse into its prereq_pms
5978  
5979      return if exists $self->{incommandcolor}
5980          && $color==1
5981          && $self->{incommandcolor}==$color;
5982      if ($depth>=$CPAN::MAX_RECURSION) {
5983          die(CPAN::Exception::RecursiveDependency->new($ancestors));
5984      }
5985      # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5986      my $prereq_pm = $self->prereq_pm;
5987      if (defined $prereq_pm) {
5988        PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5989                             keys %{$prereq_pm->{build_requires}||{}}) {
5990              next PREREQ if $pre eq "perl";
5991              my $premo;
5992              unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5993                  $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5994                  $CPAN::Frontend->mysleep(2);
5995                  next PREREQ;
5996              }
5997              $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5998          }
5999      }
6000      if ($color==0) {
6001          delete $self->{sponsored_mods};
6002  
6003          # as we are at the end of a command, we'll give up this
6004          # reminder of a broken test. Other commands may test this guy
6005          # again. Maybe 'badtestcnt' should be renamed to
6006          # 'make_test_failed_within_command'?
6007          delete $self->{badtestcnt};
6008      }
6009      $self->{incommandcolor} = $color;
6010  }
6011  
6012  #-> sub CPAN::Distribution::as_string ;
6013  sub as_string {
6014      my $self = shift;
6015      $self->containsmods;
6016      $self->upload_date;
6017      $self->SUPER::as_string(@_);
6018  }
6019  
6020  #-> sub CPAN::Distribution::containsmods ;
6021  sub containsmods {
6022      my $self = shift;
6023      return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6024      my $dist_id = $self->{ID};
6025      for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6026          my $mod_file = $mod->cpan_file or next;
6027          my $mod_id = $mod->{ID} or next;
6028          # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6029          # sleep 1;
6030          if ($CPAN::Signal) {
6031              delete $self->{CONTAINSMODS};
6032              return;
6033          }
6034          $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6035      }
6036      keys %{$self->{CONTAINSMODS}||={}};
6037  }
6038  
6039  #-> sub CPAN::Distribution::upload_date ;
6040  sub upload_date {
6041      my $self = shift;
6042      return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6043      my(@local_wanted) = split(/\//,$self->id);
6044      my $filename = pop @local_wanted;
6045      push @local_wanted, "CHECKSUMS";
6046      my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6047      return unless $author;
6048      my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6049      return unless @dl;
6050      my($dirent) = grep { $_->[2] eq $filename } @dl;
6051      # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6052      return unless $dirent->[1];
6053      return $self->{UPLOAD_DATE} = $dirent->[1];
6054  }
6055  
6056  #-> sub CPAN::Distribution::uptodate ;
6057  sub uptodate {
6058      my($self) = @_;
6059      my $c;
6060      foreach $c ($self->containsmods) {
6061          my $obj = CPAN::Shell->expandany($c);
6062          unless ($obj->uptodate) {
6063              my $id = $self->pretty_id;
6064              $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6065              return 0;
6066          }
6067      }
6068      return 1;
6069  }
6070  
6071  #-> sub CPAN::Distribution::called_for ;
6072  sub called_for {
6073      my($self,$id) = @_;
6074      $self->{CALLED_FOR} = $id if defined $id;
6075      return $self->{CALLED_FOR};
6076  }
6077  
6078  #-> sub CPAN::Distribution::get ;
6079  sub get {
6080      my($self) = @_;
6081      $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6082      if (my $goto = $self->prefs->{goto}) {
6083          $CPAN::Frontend->mywarn
6084              (sprintf(
6085                       "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6086                       $goto,
6087                       $self->{prefs_file},
6088                       $self->{prefs_file_doc},
6089                      ));
6090          return $self->goto($goto);
6091      }
6092      local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6093                             ? $ENV{PERL5LIB}
6094                             : ($ENV{PERLLIB} || "");
6095  
6096      $CPAN::META->set_perl5lib;
6097      local $ENV{MAKEFLAGS}; # protect us from outer make calls
6098  
6099    EXCUSE: {
6100          my @e;
6101          my $goodbye_message;
6102          $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6103          if ($self->prefs->{disabled}) {
6104              my $why = sprintf(
6105                                "Disabled via prefs file '%s' doc %d",
6106                                $self->{prefs_file},
6107                                $self->{prefs_file_doc},
6108                               );
6109              push @e, $why;
6110              $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6111              $goodbye_message = "[disabled] -- NA $why";
6112              # note: not intended to be persistent but at least visible
6113              # during this session
6114          } else {
6115              if (exists $self->{build_dir} && -d $self->{build_dir}
6116                  && ($self->{modulebuild}||$self->{writemakefile})
6117                 ) {
6118                  # this deserves print, not warn:
6119                  $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6120                                           "$self->{build_dir}\n"
6121                                          );
6122                  return 1;
6123              }
6124  
6125              # although we talk about 'force' we shall not test on
6126              # force directly. New model of force tries to refrain from
6127              # direct checking of force.
6128              exists $self->{unwrapped} and (
6129                                             UNIVERSAL::can($self->{unwrapped},"failed") ?
6130                                             $self->{unwrapped}->failed :
6131                                             $self->{unwrapped} =~ /^NO/
6132                                            )
6133                  and push @e, "Unwrapping had some problem, won't try again without force";
6134          }
6135          if (@e) {
6136              $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6137              if ($goodbye_message) {
6138                   $self->goodbye($goodbye_message);
6139              }
6140              return;
6141          }
6142      }
6143      my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6144  
6145      my($local_file);
6146      unless ($self->{build_dir} && -d $self->{build_dir}) {
6147          $self->get_file_onto_local_disk;
6148          return if $CPAN::Signal;
6149          $self->check_integrity;
6150          return if $CPAN::Signal;
6151          (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6152          $packagedir ||= $self->{build_dir};
6153          $self->{build_dir} = $packagedir;
6154      }
6155  
6156      if ($CPAN::Signal) {
6157          $self->safe_chdir($sub_wd);
6158          return;
6159      }
6160      return $self->run_MM_or_MB($local_file);
6161  }
6162  
6163  #-> CPAN::Distribution::get_file_onto_local_disk
6164  sub get_file_onto_local_disk {
6165      my($self) = @_;
6166  
6167      return if $self->is_dot_dist;
6168      my($local_file);
6169      my($local_wanted) =
6170          File::Spec->catfile(
6171                              $CPAN::Config->{keep_source_where},
6172                              "authors",
6173                              "id",
6174                              split(/\//,$self->id)
6175                             );
6176  
6177      $self->debug("Doing localize") if $CPAN::DEBUG;
6178      unless ($local_file =
6179              CPAN::FTP->localize("authors/id/$self->{ID}",
6180                                  $local_wanted)) {
6181          my $note = "";
6182          if ($CPAN::Index::DATE_OF_02) {
6183              $note = "Note: Current database in memory was generated ".
6184                  "on $CPAN::Index::DATE_OF_02\n";
6185          }
6186          $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6187      }
6188  
6189      $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6190      $self->{localfile} = $local_file;
6191  }
6192  
6193  
6194  #-> CPAN::Distribution::check_integrity
6195  sub check_integrity {
6196      my($self) = @_;
6197  
6198      return if $self->is_dot_dist;
6199      if ($CPAN::META->has_inst("Digest::SHA")) {
6200          $self->debug("Digest::SHA is installed, verifying");
6201          $self->verifyCHECKSUM;
6202      } else {
6203          $self->debug("Digest::SHA is NOT installed");
6204      }
6205  }
6206  
6207  #-> CPAN::Distribution::run_preps_on_packagedir
6208  sub run_preps_on_packagedir {
6209      my($self) = @_;
6210      return if $self->is_dot_dist;
6211  
6212      $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6213      my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6214      $self->safe_chdir($builddir);
6215      $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6216      File::Path::rmtree("tmp-$$");
6217      unless (mkdir "tmp-$$", 0755) {
6218          $CPAN::Frontend->unrecoverable_error(<<EOF);
6219  Couldn't mkdir '$builddir/tmp-$$': $!
6220  
6221  Cannot continue: Please find the reason why I cannot make the
6222  directory
6223  $builddir/tmp-$$
6224  and fix the problem, then retry.
6225  
6226  EOF
6227      }
6228      if ($CPAN::Signal) {
6229          return;
6230      }
6231      $self->safe_chdir("tmp-$$");
6232  
6233      #
6234      # Unpack the goods
6235      #
6236      my $local_file = $self->{localfile};
6237      my $ct = eval{CPAN::Tarzip->new($local_file)};
6238      unless ($ct) {
6239          $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6240          delete $self->{build_dir};
6241          return;
6242      }
6243      if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6244          $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6245          $self->untar_me($ct);
6246      } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6247          $self->unzip_me($ct);
6248      } else {
6249          $self->{was_uncompressed}++ unless $ct->gtest();
6250          $local_file = $self->handle_singlefile($local_file);
6251      }
6252  
6253      # we are still in the tmp directory!
6254      # Let's check if the package has its own directory.
6255      my $dh = DirHandle->new(File::Spec->curdir)
6256          or Carp::croak("Couldn't opendir .: $!");
6257      my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6258      $dh->close;
6259      my ($packagedir);
6260      # XXX here we want in each branch File::Temp to protect all build_dir directories
6261      if (CPAN->has_usable("File::Temp")) {
6262          my $tdir_base;
6263          my $from_dir;
6264          my @dirents;
6265          if (@readdir == 1 && -d $readdir[0]) {
6266              $tdir_base = $readdir[0];
6267              $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6268              my $dh2 = DirHandle->new($from_dir)
6269                  or Carp::croak("Couldn't opendir $from_dir: $!");
6270              @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6271          } else {
6272              my $userid = $self->cpan_userid;
6273              CPAN->debug("userid[$userid]");
6274              if (!$userid or $userid eq "N/A") {
6275                  $userid = "anon";
6276              }
6277              $tdir_base = $userid;
6278              $from_dir = File::Spec->curdir;
6279              @dirents = @readdir;
6280          }
6281          $packagedir = File::Temp::tempdir(
6282                                            "$tdir_base-XXXXXX",
6283                                            DIR => $builddir,
6284                                            CLEANUP => 0,
6285                                           );
6286          my $f;
6287          for $f (@dirents) { # is already without "." and ".."
6288              my $from = File::Spec->catdir($from_dir,$f);
6289              my $to = File::Spec->catdir($packagedir,$f);
6290              unless (File::Copy::move($from,$to)) {
6291                  my $err = $!;
6292                  $from = File::Spec->rel2abs($from);
6293                  Carp::confess("Couldn't move $from to $to: $err");
6294              }
6295          }
6296      } else { # older code below, still better than nothing when there is no File::Temp
6297          my($distdir);
6298          if (@readdir == 1 && -d $readdir[0]) {
6299              $distdir = $readdir[0];
6300              $packagedir = File::Spec->catdir($builddir,$distdir);
6301              $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6302                  if $CPAN::DEBUG;
6303              -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6304                                                          "$packagedir\n");
6305              File::Path::rmtree($packagedir);
6306              unless (File::Copy::move($distdir,$packagedir)) {
6307                  $CPAN::Frontend->unrecoverable_error(<<EOF);
6308  Couldn't move '$distdir' to '$packagedir': $!
6309  
6310  Cannot continue: Please find the reason why I cannot move
6311  $builddir/tmp-$$/$distdir
6312  to
6313  $packagedir
6314  and fix the problem, then retry
6315  
6316  EOF
6317              }
6318              $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6319                                   $distdir,
6320                                   $packagedir,
6321                                   -e $packagedir,
6322                                   -d $packagedir,
6323                                  )) if $CPAN::DEBUG;
6324          } else {
6325              my $userid = $self->cpan_userid;
6326              CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6327              if (!$userid or $userid eq "N/A") {
6328                  $userid = "anon";
6329              }
6330              my $pragmatic_dir = $userid . '000';
6331              $pragmatic_dir =~ s/\W_//g;
6332              $pragmatic_dir++ while -d "../$pragmatic_dir";
6333              $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6334              $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6335              File::Path::mkpath($packagedir);
6336              my($f);
6337              for $f (@readdir) { # is already without "." and ".."
6338                  my $to = File::Spec->catdir($packagedir,$f);
6339                  File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6340              }
6341          }
6342      }
6343      $self->{build_dir} = $packagedir;
6344      $self->safe_chdir($builddir);
6345      File::Path::rmtree("tmp-$$");
6346  
6347      $self->safe_chdir($packagedir);
6348      $self->_signature_business();
6349      $self->safe_chdir($builddir);
6350  
6351      return($packagedir,$local_file);
6352  }
6353  
6354  #-> sub CPAN::Distribution::parse_meta_yml ;
6355  sub parse_meta_yml {
6356      my($self) = @_;
6357      my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6358      my $yaml = File::Spec->catfile($build_dir,"META.yml");
6359      $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6360      return unless -f $yaml;
6361      my $early_yaml;
6362      eval {
6363          require Parse::Metayaml; # hypothetical
6364          $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6365      };
6366      unless ($early_yaml) {
6367          eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6368      }
6369      unless ($early_yaml) {
6370          return;
6371      }
6372      return $early_yaml;
6373  }
6374  
6375  #-> sub CPAN::Distribution::satisfy_configure_requires ;
6376  sub satisfy_configure_requires {
6377      my($self) = @_;
6378      my $enable_configure_requires = 1;
6379      if (!$enable_configure_requires) {
6380          return 1;
6381          # if we return 1 here, everything is as before we introduced
6382          # configure_requires that means, things with
6383          # configure_requires simply fail, all others succeed
6384      }
6385      my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6386      if ($self->{configure_requires_later}) {
6387          for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6388              if ($self->{configure_requires_later_for}{$k}>1) {
6389                  # we must not come here a second time
6390                  $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6391                  require YAML::Syck;
6392                  $CPAN::Frontend->mydie
6393                      (
6394                       YAML::Syck::Dump
6395                       ({self=>$self, prereq=>\@prereq})
6396                      );
6397              }
6398          }
6399      }
6400      if ($prereq[0][0] eq "perl") {
6401          my $need = "requires perl '$prereq[0][1]'";
6402          my $id = $self->pretty_id;
6403          $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6404          $self->{make} = CPAN::Distrostatus->new("NO $need");
6405          $self->store_persistent_state;
6406          return $self->goodbye("[prereq] -- NOT OK");
6407      } else {
6408          my $follow = eval {
6409              $self->follow_prereqs("configure_requires_later", @prereq);
6410          };
6411          if (0) {
6412          } elsif ($follow) {
6413              return;
6414          } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6415              $CPAN::Frontend->mywarn($@);
6416              return $self->goodbye("[depend] -- NOT OK");
6417          }
6418      }
6419      die "never reached";
6420  }
6421  
6422  #-> sub CPAN::Distribution::run_MM_or_MB ;
6423  sub run_MM_or_MB {
6424      my($self,$local_file) = @_;
6425      $self->satisfy_configure_requires() or return;
6426      my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6427      my($mpl_exists) = -f $mpl;
6428      unless ($mpl_exists) {
6429          # NFS has been reported to have racing problems after the
6430          # renaming of a directory in some environments.
6431          # This trick helps.
6432          $CPAN::Frontend->mysleep(1);
6433          my $mpldh = DirHandle->new($self->{build_dir})
6434              or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6435          $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6436          $mpldh->close;
6437      }
6438      my $prefer_installer = "eumm"; # eumm|mb
6439      if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6440          if ($mpl_exists) { # they *can* choose
6441              if ($CPAN::META->has_inst("Module::Build")) {
6442                  $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6443                                                                       q{prefer_installer});
6444              }
6445          } else {
6446              $prefer_installer = "mb";
6447          }
6448      }
6449      return unless $self->patch;
6450      if (lc($prefer_installer) eq "rand") {
6451          $prefer_installer = rand()<.5 ? "eumm" : "mb";
6452      }
6453      if (lc($prefer_installer) eq "mb") {
6454          $self->{modulebuild} = 1;
6455      } elsif ($self->{archived} eq "patch") {
6456          # not an edge case, nothing to install for sure
6457          my $why = "A patch file cannot be installed";
6458          $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6459          $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6460      } elsif (! $mpl_exists) {
6461          $self->_edge_cases($mpl,$local_file);
6462      }
6463      if ($self->{build_dir}
6464          &&
6465          $CPAN::Config->{build_dir_reuse}
6466         ) {
6467          $self->store_persistent_state;
6468      }
6469      return $self;
6470  }
6471  
6472  #-> CPAN::Distribution::store_persistent_state
6473  sub store_persistent_state {
6474      my($self) = @_;
6475      my $dir = $self->{build_dir};
6476      unless (File::Spec->canonpath(File::Basename::dirname($dir))
6477              eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6478          $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6479                                  "will not store persistent state\n");
6480          return;
6481      }
6482      my $file = sprintf "%s.yml", $dir;
6483      my $yaml_module = CPAN::_yaml_module;
6484      if ($CPAN::META->has_inst($yaml_module)) {
6485          CPAN->_yaml_dumpfile(
6486                               $file,
6487                               {
6488                                time => time,
6489                                perl => CPAN::_perl_fingerprint,
6490                                distribution => $self,
6491                               }
6492                              );
6493      } else {
6494          $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6495                                  "will not store persistent state\n");
6496      }
6497  }
6498  
6499  #-> CPAN::Distribution::try_download
6500  sub try_download {
6501      my($self,$patch) = @_;
6502      my $norm = $self->normalize($patch);
6503      my($local_wanted) =
6504          File::Spec->catfile(
6505                              $CPAN::Config->{keep_source_where},
6506                              "authors",
6507                              "id",
6508                              split(/\//,$norm),
6509                             );
6510      $self->debug("Doing localize") if $CPAN::DEBUG;
6511      return CPAN::FTP->localize("authors/id/$norm",
6512                                 $local_wanted);
6513  }
6514  
6515  {
6516      my $stdpatchargs = "";
6517      #-> CPAN::Distribution::patch
6518      sub patch {
6519          my($self) = @_;
6520          $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6521          my $patches = $self->prefs->{patches};
6522          $patches ||= "";
6523          $self->debug("patches[$patches]") if $CPAN::DEBUG;
6524          if ($patches) {
6525              return unless @$patches;
6526              $self->safe_chdir($self->{build_dir});
6527              CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6528              my $patchbin = $CPAN::Config->{patch};
6529              unless ($patchbin && length $patchbin) {
6530                  $CPAN::Frontend->mydie("No external patch command configured\n\n".
6531                                         "Please run 'o conf init /patch/'\n\n");
6532              }
6533              unless (MM->maybe_command($patchbin)) {
6534                  $CPAN::Frontend->mydie("No external patch command available\n\n".
6535                                         "Please run 'o conf init /patch/'\n\n");
6536              }
6537              $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6538              local $ENV{PATCH_GET} = 0; # formerly known as -g0
6539              unless ($stdpatchargs) {
6540                  my $system = "$patchbin --version |";
6541                  local *FH;
6542                  open FH, $system or die "Could not fork '$system': $!";
6543                  local $/ = "\n";
6544                  my $pversion;
6545                PARSEVERSION: while (<FH>) {
6546                      if (/^patch\s+([\d\.]+)/) {
6547                          $pversion = $1;
6548                          last PARSEVERSION;
6549                      }
6550                  }
6551                  if ($pversion) {
6552                      $stdpatchargs = "-N --fuzz=3";
6553                  } else {
6554                      $stdpatchargs = "-N";
6555                  }
6556              }
6557              my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6558              $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6559              for my $patch (@$patches) {
6560                  unless (-f $patch) {
6561                      if (my $trydl = $self->try_download($patch)) {
6562                          $patch = $trydl;
6563                      } else {
6564                          my $fail = "Could not find patch '$patch'";
6565                          $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6566                          $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6567                          delete $self->{build_dir};
6568                          return;
6569                      }
6570                  }
6571                  $CPAN::Frontend->myprint("  $patch\n");
6572                  my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6573  
6574                  my $pcommand;
6575                  my $ppp = $self->_patch_p_parameter($readfh);
6576                  if ($ppp eq "applypatch") {
6577                      $pcommand = "$CPAN::Config->{applypatch} -verbose";
6578                  } else {
6579                      my $thispatchargs = join " ", $stdpatchargs, $ppp;
6580                      $pcommand = "$patchbin $thispatchargs";
6581                  }
6582  
6583                  $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6584                  my $writefh = FileHandle->new;
6585                  $CPAN::Frontend->myprint("  $pcommand\n");
6586                  unless (open $writefh, "|$pcommand") {
6587                      my $fail = "Could not fork '$pcommand'";
6588                      $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6589                      $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6590                      delete $self->{build_dir};
6591                      return;
6592                  }
6593                  while (my $x = $readfh->READLINE) {
6594                      print $writefh $x;
6595                  }
6596                  unless (close $writefh) {
6597                      my $fail = "Could not apply patch '$patch'";
6598                      $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6599                      $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6600                      delete $self->{build_dir};
6601                      return;
6602                  }
6603              }
6604              $self->{patched}++;
6605          }
6606          return 1;
6607      }
6608  }
6609  
6610  sub _patch_p_parameter {
6611      my($self,$fh) = @_;
6612      my $cnt_files   = 0;
6613      my $cnt_p0files = 0;
6614      local($_);
6615      while ($_ = $fh->READLINE) {
6616          if (
6617              $CPAN::Config->{applypatch}
6618              &&
6619              /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6620             ) {
6621              return "applypatch"
6622          }
6623          next unless /^[\*\+]{3}\s(\S+)/;
6624          my $file = $1;
6625          $cnt_files++;
6626          $cnt_p0files++ if -f $file;
6627          CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6628              if $CPAN::DEBUG;
6629      }
6630      return "-p1" unless $cnt_files;
6631      return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6632  }
6633  
6634  #-> sub CPAN::Distribution::_edge_cases
6635  # with "configure" or "Makefile" or single file scripts
6636  sub _edge_cases {
6637      my($self,$mpl,$local_file) = @_;
6638      $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6639                           $mpl,
6640                           CPAN::anycwd(),
6641                          )) if $CPAN::DEBUG;
6642      my $build_dir = $self->{build_dir};
6643      my($configure) = File::Spec->catfile($build_dir,"Configure");
6644      if (-f $configure) {
6645          # do we have anything to do?
6646          $self->{configure} = $configure;
6647      } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6648          $CPAN::Frontend->mywarn(qq{
6649  Package comes with a Makefile and without a Makefile.PL.
6650  We\'ll try to build it with that Makefile then.
6651  });
6652          $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6653          $CPAN::Frontend->mysleep(2);
6654      } else {
6655          my $cf = $self->called_for || "unknown";
6656          if ($cf =~ m|/|) {
6657              $cf =~ s|.*/||;
6658              $cf =~ s|\W.*||;
6659          }
6660          $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6661          $cf = "unknown" unless length($cf);
6662          $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6663    (The test -f "$mpl" returned false.)
6664    Writing one on our own (setting NAME to $cf)\a\n});
6665          $self->{had_no_makefile_pl}++;
6666          $CPAN::Frontend->mysleep(3);
6667  
6668          # Writing our own Makefile.PL
6669  
6670          my $script = "";
6671          if ($self->{archived} eq "maybe_pl") {
6672              my $fh = FileHandle->new;
6673              my $script_file = File::Spec->catfile($build_dir,$local_file);
6674              $fh->open($script_file)
6675                  or Carp::croak("Could not open script '$script_file': $!");
6676              local $/ = "\n";
6677              # name parsen und prereq
6678              my($state) = "poddir";
6679              my($name, $prereq) = ("", "");
6680              while (<$fh>) {
6681                  if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6682                      if ($1 eq 'NAME') {
6683                          $state = "name";
6684                      } elsif ($1 eq 'PREREQUISITES') {
6685                          $state = "prereq";
6686                      }
6687                  } elsif ($state =~ m{^(name|prereq)$}) {
6688                      if (/^=/) {
6689                          $state = "poddir";
6690                      } elsif (/^\s*$/) {
6691                          # nop
6692                      } elsif ($state eq "name") {
6693                          if ($name eq "") {
6694                              ($name) = /^(\S+)/;
6695                              $state = "poddir";
6696                          }
6697                      } elsif ($state eq "prereq") {
6698                          $prereq .= $_;
6699                      }
6700                  } elsif (/^=cut\b/) {
6701                      last;
6702                  }
6703              }
6704              $fh->close;
6705  
6706              for ($name) {
6707                  s{.*<}{};       # strip X<...>
6708                  s{>.*}{};
6709              }
6710              chomp $prereq;
6711              $prereq = join " ", split /\s+/, $prereq;
6712              my($PREREQ_PM) = join("\n", map {
6713                  s{.*<}{};       # strip X<...>
6714                  s{>.*}{};
6715                  if (/[\s\'\"]/) { # prose?
6716                  } else {
6717                      s/[^\w:]$//; # period?
6718                      " "x28 . "'$_' => 0,";
6719                  }
6720              } split /\s*,\s*/, $prereq);
6721  
6722              $script = "
6723                EXE_FILES => ['$name'],
6724                PREREQ_PM => {
6725  $PREREQ_PM
6726                             },
6727  ";
6728              if ($name) {
6729                  my $to_file = File::Spec->catfile($build_dir, $name);
6730                  rename $script_file, $to_file
6731                      or die "Can't rename $script_file to $to_file: $!";
6732              }
6733          }
6734  
6735          my $fh = FileHandle->new;
6736          $fh->open(">$mpl")
6737              or Carp::croak("Could not open >$mpl: $!");
6738          $fh->print(
6739                     qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6740  # because there was no Makefile.PL supplied.
6741  # Autogenerated on: }.scalar localtime().qq{
6742  
6743  use ExtUtils::MakeMaker;
6744  WriteMakefile(
6745                NAME => q[$cf],$script
6746               );
6747  });
6748          $fh->close;
6749      }
6750  }
6751  
6752  #-> CPAN::Distribution::_signature_business
6753  sub _signature_business {
6754      my($self) = @_;
6755      my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6756                                                        q{check_sigs});
6757      if ($check_sigs) {
6758          if ($CPAN::META->has_inst("Module::Signature")) {
6759              if (-f "SIGNATURE") {
6760                  $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6761                  my $rv = Module::Signature::verify();
6762                  if ($rv != Module::Signature::SIGNATURE_OK() and
6763                      $rv != Module::Signature::SIGNATURE_MISSING()) {
6764                      $CPAN::Frontend->mywarn(
6765                                              qq{\nSignature invalid for }.
6766                                              qq{distribution file. }.
6767                                              qq{Please investigate.\n\n}
6768                                             );
6769  
6770                      my $wrap =
6771                          sprintf(qq{I'd recommend removing %s. Some error occured    }.
6772                                  qq{while checking its signature, so it could        }.
6773                                  qq{be invalid. Maybe you have configured            }.
6774                                  qq{your 'urllist' with a bad URL. Please check this }.
6775                                  qq{array with 'o conf urllist' and retry. Or        }.
6776                                  qq{examine the distribution in a subshell. Try
6777    look %s
6778  and run
6779    cpansign -v
6780  },
6781                                  $self->{localfile},
6782                                  $self->pretty_id,
6783                                 );
6784                      $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6785                      $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6786                      $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6787                  } else {
6788                      $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6789                      $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6790                  }
6791              } else {
6792                  $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6793              }
6794          } else {
6795              $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6796          }
6797      }
6798  }
6799  
6800  #-> CPAN::Distribution::untar_me ;
6801  sub untar_me {
6802      my($self,$ct) = @_;
6803      $self->{archived} = "tar";
6804      if ($ct->untar()) {
6805          $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6806      } else {
6807          $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6808      }
6809  }
6810  
6811  # CPAN::Distribution::unzip_me ;
6812  sub unzip_me {
6813      my($self,$ct) = @_;
6814      $self->{archived} = "zip";
6815      if ($ct->unzip()) {
6816          $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6817      } else {
6818          $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6819      }
6820      return;
6821  }
6822  
6823  sub handle_singlefile {
6824      my($self,$local_file) = @_;
6825  
6826      if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6827          $self->{archived} = "pm";
6828      } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6829          $self->{archived} = "patch";
6830      } else {
6831          $self->{archived} = "maybe_pl";
6832      }
6833  
6834      my $to = File::Basename::basename($local_file);
6835      if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6836          if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6837              $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6838          } else {
6839              $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6840          }
6841      } else {
6842          if (File::Copy::cp($local_file,".")) {
6843              $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6844          } else {
6845              $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6846          }
6847      }
6848      return $to;
6849  }
6850  
6851  #-> sub CPAN::Distribution::new ;
6852  sub new {
6853      my($class,%att) = @_;
6854  
6855      # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6856  
6857      my $this = { %att };
6858      return bless $this, $class;
6859  }
6860  
6861  #-> sub CPAN::Distribution::look ;
6862  sub look {
6863      my($self) = @_;
6864  
6865      if ($^O eq 'MacOS') {
6866        $self->Mac::BuildTools::look;
6867        return;
6868      }
6869  
6870      if (  $CPAN::Config->{'shell'} ) {
6871          $CPAN::Frontend->myprint(qq{
6872  Trying to open a subshell in the build directory...
6873  });
6874      } else {
6875          $CPAN::Frontend->myprint(qq{
6876  Your configuration does not define a value for subshells.
6877  Please define it with "o conf shell <your shell>"
6878  });
6879          return;
6880      }
6881      my $dist = $self->id;
6882      my $dir;
6883      unless ($dir = $self->dir) {
6884          $self->get;
6885      }
6886      unless ($dir ||= $self->dir) {
6887          $CPAN::Frontend->mywarn(qq{
6888  Could not determine which directory to use for looking at $dist.
6889  });
6890          return;
6891      }
6892      my $pwd  = CPAN::anycwd();
6893      $self->safe_chdir($dir);
6894      $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6895      {
6896          local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6897          $ENV{CPAN_SHELL_LEVEL} += 1;
6898          my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6899          unless (system($shell) == 0) {
6900              my $code = $? >> 8;
6901              $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6902          }
6903      }
6904      $self->safe_chdir($pwd);
6905  }
6906  
6907  # CPAN::Distribution::cvs_import ;
6908  sub cvs_import {
6909      my($self) = @_;
6910      $self->get;
6911      my $dir = $self->dir;
6912  
6913      my $package = $self->called_for;
6914      my $module = $CPAN::META->instance('CPAN::Module', $package);
6915      my $version = $module->cpan_version;
6916  
6917      my $userid = $self->cpan_userid;
6918  
6919      my $cvs_dir = (split /\//, $dir)[-1];
6920      $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6921      my $cvs_root =
6922        $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6923      my $cvs_site_perl =
6924        $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6925      if ($cvs_site_perl) {
6926          $cvs_dir = "$cvs_site_perl/$cvs_dir";
6927      }
6928      my $cvs_log = qq{"imported $package $version sources"};
6929      $version =~ s/\./_/g;
6930      # XXX cvs: undocumented and unclear how it was meant to work
6931      my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6932                 "$cvs_dir", $userid, "v$version");
6933  
6934      my $pwd  = CPAN::anycwd();
6935      chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6936  
6937      $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6938  
6939      $CPAN::Frontend->myprint(qq{@cmd\n});
6940      system(@cmd) == 0 or
6941      # XXX cvs
6942          $CPAN::Frontend->mydie("cvs import failed");
6943      chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6944  }
6945  
6946  #-> sub CPAN::Distribution::readme ;
6947  sub readme {
6948      my($self) = @_;
6949      my($dist) = $self->id;
6950      my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6951      $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6952      my($local_file);
6953      my($local_wanted) =
6954          File::Spec->catfile(
6955                              $CPAN::Config->{keep_source_where},
6956                              "authors",
6957                              "id",
6958                              split(/\//,"$sans.readme"),
6959                             );
6960      $self->debug("Doing localize") if $CPAN::DEBUG;
6961      $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6962                                        $local_wanted)
6963          or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6964  
6965      if ($^O eq 'MacOS') {
6966          Mac::BuildTools::launch_file($local_file);
6967          return;
6968      }
6969  
6970      my $fh_pager = FileHandle->new;
6971      local($SIG{PIPE}) = "IGNORE";
6972      my $pager = $CPAN::Config->{'pager'} || "cat";
6973      $fh_pager->open("|$pager")
6974          or die "Could not open pager $pager\: $!";
6975      my $fh_readme = FileHandle->new;
6976      $fh_readme->open($local_file)
6977          or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6978      $CPAN::Frontend->myprint(qq{
6979  Displaying file
6980    $local_file
6981  with pager "$pager"
6982  });
6983      $fh_pager->print(<$fh_readme>);
6984      $fh_pager->close;
6985  }
6986  
6987  #-> sub CPAN::Distribution::verifyCHECKSUM ;
6988  sub verifyCHECKSUM {
6989      my($self) = @_;
6990    EXCUSE: {
6991          my @e;
6992          $self->{CHECKSUM_STATUS} ||= "";
6993          $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6994          $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6995      }
6996      my($lc_want,$lc_file,@local,$basename);
6997      @local = split(/\//,$self->id);
6998      pop @local;
6999      push @local, "CHECKSUMS";
7000      $lc_want =
7001          File::Spec->catfile($CPAN::Config->{keep_source_where},
7002                              "authors", "id", @local);
7003      local($") = "/";
7004      if (my $size = -s $lc_want) {
7005          $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7006          if ($self->CHECKSUM_check_file($lc_want,1)) {
7007              return $self->{CHECKSUM_STATUS} = "OK";
7008          }
7009      }
7010      $lc_file = CPAN::FTP->localize("authors/id/@local",
7011                                     $lc_want,1);
7012      unless ($lc_file) {
7013          $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7014          $local[-1] .= ".gz";
7015          $lc_file = CPAN::FTP->localize("authors/id/@local",
7016                                         "$lc_want.gz",1);
7017          if ($lc_file) {
7018              $lc_file =~ s/\.gz(?!\n)\Z//;
7019              eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7020          } else {
7021              return;
7022          }
7023      }
7024      if ($self->CHECKSUM_check_file($lc_file)) {
7025          return $self->{CHECKSUM_STATUS} = "OK";
7026      }
7027  }
7028  
7029  #-> sub CPAN::Distribution::SIG_check_file ;
7030  sub SIG_check_file {
7031      my($self,$chk_file) = @_;
7032      my $rv = eval { Module::Signature::_verify($chk_file) };
7033  
7034      if ($rv == Module::Signature::SIGNATURE_OK()) {
7035          $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7036          return $self->{SIG_STATUS} = "OK";
7037      } else {
7038          $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7039                                   qq{distribution file. }.
7040                                   qq{Please investigate.\n\n}.
7041                                   $self->as_string,
7042                                   $CPAN::META->instance(
7043                                                         'CPAN::Author',
7044                                                         $self->cpan_userid
7045                                                        )->as_string);
7046  
7047          my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7048  is invalid. Maybe you have configured your 'urllist' with
7049  a bad URL. Please check this array with 'o conf urllist', and
7050  retry.};
7051  
7052          $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7053      }
7054  }
7055  
7056  #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7057  
7058  # sloppy is 1 when we have an old checksums file that maybe is good
7059  # enough
7060  
7061  sub CHECKSUM_check_file {
7062      my($self,$chk_file,$sloppy) = @_;
7063      my($cksum,$file,$basename);
7064  
7065      $sloppy ||= 0;
7066      $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7067      my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7068                                                        q{check_sigs});
7069      if ($check_sigs) {
7070          if ($CPAN::META->has_inst("Module::Signature")) {
7071              $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7072              $self->SIG_check_file($chk_file);
7073          } else {
7074              $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7075          }
7076      }
7077  
7078      $file = $self->{localfile};
7079      $basename = File::Basename::basename($file);
7080      my $fh = FileHandle->new;
7081      if (open $fh, $chk_file) {
7082          local($/);
7083          my $eval = <$fh>;
7084          $eval =~ s/\015?\012/\n/g;
7085          close $fh;
7086          my($comp) = Safe->new();
7087          $cksum = $comp->reval($eval);
7088          if ($@) {
7089              rename $chk_file, "$chk_file.bad";
7090              Carp::confess($@) if $@;
7091          }
7092      } else {
7093          Carp::carp "Could not open $chk_file for reading";
7094      }
7095  
7096      if (! ref $cksum or ref $cksum ne "HASH") {
7097          $CPAN::Frontend->mywarn(qq{
7098  Warning: checksum file '$chk_file' broken.
7099  
7100  When trying to read that file I expected to get a hash reference
7101  for further processing, but got garbage instead.
7102  });
7103          my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7104          $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7105          $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7106          return;
7107      } elsif (exists $cksum->{$basename}{sha256}) {
7108          $self->debug("Found checksum for $basename:" .
7109                       "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7110  
7111          open($fh, $file);
7112          binmode $fh;
7113          my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7114          $fh->close;
7115          $fh = CPAN::Tarzip->TIEHANDLE($file);
7116  
7117          unless ($eq) {
7118              my $dg = Digest::SHA->new(256);
7119              my($data,$ref);
7120              $ref = \$data;
7121              while ($fh->READ($ref, 4096) > 0) {
7122                  $dg->add($data);
7123              }
7124              my $hexdigest = $dg->hexdigest;
7125              $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7126          }
7127  
7128          if ($eq) {
7129              $CPAN::Frontend->myprint("Checksum for $file ok\n");
7130              return $self->{CHECKSUM_STATUS} = "OK";
7131          } else {
7132              $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7133                                       qq{distribution file. }.
7134                                       qq{Please investigate.\n\n}.
7135                                       $self->as_string,
7136                                       $CPAN::META->instance(
7137                                                             'CPAN::Author',
7138                                                             $self->cpan_userid
7139                                                            )->as_string);
7140  
7141              my $wrap = qq{I\'d recommend removing $file. Its
7142  checksum is incorrect. Maybe you have configured your 'urllist' with
7143  a bad URL. Please check this array with 'o conf urllist', and
7144  retry.};
7145  
7146              $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7147  
7148              # former versions just returned here but this seems a
7149              # serious threat that deserves a die
7150  
7151              # $CPAN::Frontend->myprint("\n\n");
7152              # sleep 3;
7153              # return;
7154          }
7155          # close $fh if fileno($fh);
7156      } else {
7157          return if $sloppy;
7158          unless ($self->{CHECKSUM_STATUS}) {
7159              $CPAN::Frontend->mywarn(qq{
7160  Warning: No checksum for $basename in $chk_file.
7161  
7162  The cause for this may be that the file is very new and the checksum
7163  has not yet been calculated, but it may also be that something is
7164  going awry right now.
7165  });
7166              my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7167              $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7168          }
7169          $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7170          return;
7171      }
7172  }
7173  
7174  #-> sub CPAN::Distribution::eq_CHECKSUM ;
7175  sub eq_CHECKSUM {
7176      my($self,$fh,$expect) = @_;
7177      if ($CPAN::META->has_inst("Digest::SHA")) {
7178          my $dg = Digest::SHA->new(256);
7179          my($data);
7180          while (read($fh, $data, 4096)) {
7181              $dg->add($data);
7182          }
7183          my $hexdigest = $dg->hexdigest;
7184          # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7185          return $hexdigest eq $expect;
7186      }
7187      return 1;
7188  }
7189  
7190  #-> sub CPAN::Distribution::force ;
7191  
7192  # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7193  # effect by autoinspection, not by inspecting a global variable. One
7194  # of the reason why this was chosen to work that way was the treatment
7195  # of dependencies. They should not automatically inherit the force
7196  # status. But this has the downside that ^C and die() will return to
7197  # the prompt but will not be able to reset the force_update
7198  # attributes. We try to correct for it currently in the read_metadata
7199  # routine, and immediately before we check for a Signal. I hope this
7200  # works out in one of v1.57_53ff
7201  
7202  # "Force get forgets previous error conditions"
7203  
7204  #-> sub CPAN::Distribution::fforce ;
7205  sub fforce {
7206    my($self, $method) = @_;
7207    $self->force($method,1);
7208  }
7209  
7210  #-> sub CPAN::Distribution::force ;
7211  sub force {
7212    my($self, $method,$fforce) = @_;
7213    my %phase_map = (
7214                     get => [
7215                             "unwrapped",
7216                             "build_dir",
7217                             "archived",
7218                             "localfile",
7219                             "CHECKSUM_STATUS",
7220                             "signature_verify",
7221                             "prefs",
7222                             "prefs_file",
7223                             "prefs_file_doc",
7224                            ],
7225                     make => [
7226                              "writemakefile",
7227                              "make",
7228                              "modulebuild",
7229                              "prereq_pm",
7230                              "prereq_pm_detected",
7231                             ],
7232                     test => [
7233                              "badtestcnt",
7234                              "make_test",
7235                             ],
7236                     install => [
7237                                 "install",
7238                                ],
7239                     unknown => [
7240                                 "reqtype",
7241                                 "yaml_content",
7242                                ],
7243                    );
7244    my $methodmatch = 0;
7245    my $ldebug = 0;
7246   PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7247        $methodmatch = 1 if $fforce || $phase eq $method;
7248        next unless $methodmatch;
7249      ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7250            if ($phase eq "get") {
7251                if (substr($self->id,-1,1) eq "."
7252                    && $att =~ /(unwrapped|build_dir|archived)/ ) {
7253                    # cannot be undone for local distros
7254                    next ATTRIBUTE;
7255                }
7256                if ($att eq "build_dir"
7257                    && $self->{build_dir}
7258                    && $CPAN::META->{is_tested}
7259                   ) {
7260                    delete $CPAN::META->{is_tested}{$self->{build_dir}};
7261                }
7262            } elsif ($phase eq "test") {
7263                if ($att eq "make_test"
7264                    && $self->{make_test}
7265                    && $self->{make_test}{COMMANDID}
7266                    && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7267                   ) {
7268                    # endless loop too likely
7269                    next ATTRIBUTE;
7270                }
7271            }
7272            delete $self->{$att};
7273            if ($ldebug || $CPAN::DEBUG) {
7274                # local $CPAN::DEBUG = 16; # Distribution
7275                CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7276            }
7277        }
7278    }
7279    if ($method && $method =~ /make|test|install/) {
7280      $self->{force_update} = 1; # name should probably have been force_install
7281    }
7282  }
7283  
7284  #-> sub CPAN::Distribution::notest ;
7285  sub notest {
7286    my($self, $method) = @_;
7287    # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7288    $self->{"notest"}++; # name should probably have been force_install
7289  }
7290  
7291  #-> sub CPAN::Distribution::unnotest ;
7292  sub unnotest {
7293    my($self) = @_;
7294    # warn "XDEBUG: deleting notest";
7295    delete $self->{notest};
7296  }
7297  
7298  #-> sub CPAN::Distribution::unforce ;
7299  sub unforce {
7300    my($self) = @_;
7301    delete $self->{force_update};
7302  }
7303  
7304  #-> sub CPAN::Distribution::isa_perl ;
7305  sub isa_perl {
7306    my($self) = @_;
7307    my $file = File::Basename::basename($self->id);
7308    if ($file =~ m{ ^ perl
7309                    -?
7310                    (5)
7311                    ([._-])
7312                    (
7313                     \d{3}(_[0-4][0-9])?
7314                     |
7315                     \d+\.\d+
7316                    )
7317                    \.tar[._-](?:gz|bz2)
7318                    (?!\n)\Z
7319                  }xs) {
7320      return "$1.$3";
7321    } elsif ($self->cpan_comment
7322             &&
7323             $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7324      return $1;
7325    }
7326  }
7327  
7328  
7329  #-> sub CPAN::Distribution::perl ;
7330  sub perl {
7331      my ($self) = @_;
7332      if (! $self) {
7333          use Carp qw(carp);
7334          carp __PACKAGE__ . "::perl was called without parameters.";
7335      }
7336      return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7337  }
7338  
7339  
7340  #-> sub CPAN::Distribution::make ;
7341  sub make {
7342      my($self) = @_;
7343      if (my $goto = $self->prefs->{goto}) {
7344          return $self->goto($goto);
7345      }
7346      my $make = $self->{modulebuild} ? "Build" : "make";
7347      # Emergency brake if they said install Pippi and get newest perl
7348      if ($self->isa_perl) {
7349          if (
7350              $self->called_for ne $self->id &&
7351              ! $self->{force_update}
7352          ) {
7353              # if we die here, we break bundles
7354              $CPAN::Frontend
7355                  ->mywarn(sprintf(
7356                              qq{The most recent version "%s" of the module "%s"
7357  is part of the perl-%s distribution. To install that, you need to run
7358    force install %s   --or--
7359    install %s
7360  },
7361                               $CPAN::META->instance(
7362                                                     'CPAN::Module',
7363                                                     $self->called_for
7364                                                    )->cpan_version,
7365                               $self->called_for,
7366                               $self->isa_perl,
7367                               $self->called_for,
7368                               $self->id,
7369                              ));
7370              $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7371              $CPAN::Frontend->mysleep(1);
7372              return;
7373          }
7374      }
7375      $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7376      $self->get;
7377      if ($self->{configure_requires_later}) {
7378          return;
7379      }
7380      local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7381                             ? $ENV{PERL5LIB}
7382                             : ($ENV{PERLLIB} || "");
7383      $CPAN::META->set_perl5lib;
7384      local $ENV{MAKEFLAGS}; # protect us from outer make calls
7385  
7386      if ($CPAN::Signal) {
7387          delete $self->{force_update};
7388          return;
7389      }
7390  
7391      my $builddir;
7392    EXCUSE: {
7393          my @e;
7394          if (!$self->{archived} || $self->{archived} eq "NO") {
7395              push @e, "Is neither a tar nor a zip archive.";
7396          }
7397  
7398          if (!$self->{unwrapped}
7399              || (
7400                  UNIVERSAL::can($self->{unwrapped},"failed") ?
7401                  $self->{unwrapped}->failed :
7402                  $self->{unwrapped} =~ /^NO/
7403                 )) {
7404              push @e, "Had problems unarchiving. Please build manually";
7405          }
7406  
7407          unless ($self->{force_update}) {
7408              exists $self->{signature_verify} and
7409                  (
7410                   UNIVERSAL::can($self->{signature_verify},"failed") ?
7411                   $self->{signature_verify}->failed :
7412                   $self->{signature_verify} =~ /^NO/
7413                  )
7414                  and push @e, "Did not pass the signature test.";
7415          }
7416  
7417          if (exists $self->{writemakefile} &&
7418              (
7419               UNIVERSAL::can($self->{writemakefile},"failed") ?
7420               $self->{writemakefile}->failed :
7421               $self->{writemakefile} =~ /^NO/
7422              )) {
7423              # XXX maybe a retry would be in order?
7424              my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7425                  $self->{writemakefile}->text :
7426                      $self->{writemakefile};
7427              $err =~ s/^NO\s*//;
7428              $err ||= "Had some problem writing Makefile";
7429              $err .= ", won't make";
7430              push @e, $err;
7431          }
7432  
7433          if (defined $self->{make}) {
7434              if (UNIVERSAL::can($self->{make},"failed") ?
7435                  $self->{make}->failed :
7436                  $self->{make} =~ /^NO/) {
7437                  if ($self->{force_update}) {
7438                      # Trying an already failed 'make' (unless somebody else blocks)
7439                  } else {
7440                      # introduced for turning recursion detection into a distrostatus
7441                      my $error = length $self->{make}>3
7442                          ? substr($self->{make},3) : "Unknown error";
7443                      $CPAN::Frontend->mywarn("Could not make: $error\n");
7444                      $self->store_persistent_state;
7445                      return;
7446                  }
7447              } else {
7448                  push @e, "Has already been made";
7449              }
7450          }
7451  
7452          my $later = $self->{later} || $self->{configure_requires_later};
7453          if ($later) { # see also undelay
7454              if ($later) {
7455                  push @e, $later;
7456              }
7457          }
7458  
7459          $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7460          $builddir = $self->dir or
7461              $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7462          unless (chdir $builddir) {
7463              push @e, "Couldn't chdir to '$builddir': $!";
7464          }
7465          $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7466      }
7467      if ($CPAN::Signal) {
7468          delete $self->{force_update};
7469          return;
7470      }
7471      $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7472      $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7473  
7474      if ($^O eq 'MacOS') {
7475          Mac::BuildTools::make($self);
7476          return;
7477      }
7478  
7479      my %env;
7480      while (my($k,$v) = each %ENV) {
7481          next unless defined $v;
7482          $env{$k} = $v;
7483      }
7484      local %ENV = %env;
7485      my $system;
7486      if (my $commandline = $self->prefs->{pl}{commandline}) {
7487          $system = $commandline;
7488          $ENV{PERL} = $^X;
7489      } elsif ($self->{'configure'}) {
7490          $system = $self->{'configure'};
7491      } elsif ($self->{modulebuild}) {
7492          my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7493          $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7494      } else {
7495          my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7496          my $switch = "";
7497  # This needs a handler that can be turned on or off:
7498  #        $switch = "-MExtUtils::MakeMaker ".
7499  #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7500  #            if $] > 5.00310;
7501          my $makepl_arg = $self->make_x_arg("pl");
7502          $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7503                                                              "Makefile.PL");
7504          $system = sprintf("%s%s Makefile.PL%s",
7505                            $perl,
7506                            $switch ? " $switch" : "",
7507                            $makepl_arg ? " $makepl_arg" : "",
7508                           );
7509      }
7510      if (my $env = $self->prefs->{pl}{env}) {
7511          for my $e (keys %$env) {
7512              $ENV{$e} = $env->{$e};
7513          }
7514      }
7515      if (exists $self->{writemakefile}) {
7516      } else {
7517          local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7518          my($ret,$pid,$output);
7519          $@ = "";
7520          my $go_via_alarm;
7521          if ($CPAN::Config->{inactivity_timeout}) {
7522              require Config;
7523              if ($Config::Config{d_alarm}
7524                  &&
7525                  $Config::Config{d_alarm} eq "define"
7526                 ) {
7527                  $go_via_alarm++
7528              } else {
7529                  $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7530                                          "variable 'inactivity_timeout' to ".
7531                                          "'$CPAN::Config->{inactivity_timeout}'. But ".
7532                                          "on this machine the system call 'alarm' ".
7533                                          "isn't available. This means that we cannot ".
7534                                          "provide the feature of intercepting long ".
7535                                          "waiting code and will turn this feature off.\n"
7536                                         );
7537                  $CPAN::Config->{inactivity_timeout} = 0;
7538              }
7539          }
7540          if ($go_via_alarm) {
7541              if ( $self->_should_report('pl') ) {
7542                  ($output, $ret) = CPAN::Reporter::record_command(
7543                      $system,
7544                      $CPAN::Config->{inactivity_timeout},
7545                  );
7546                  CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7547              }
7548              else {
7549                  eval {
7550                      alarm $CPAN::Config->{inactivity_timeout};
7551                      local $SIG{CHLD}; # = sub { wait };
7552                      if (defined($pid = fork)) {
7553                          if ($pid) { #parent
7554                              # wait;
7555                              waitpid $pid, 0;
7556                          } else {    #child
7557                              # note, this exec isn't necessary if
7558                              # inactivity_timeout is 0. On the Mac I'd
7559                              # suggest, we set it always to 0.
7560                              exec $system;
7561                          }
7562                      } else {
7563                          $CPAN::Frontend->myprint("Cannot fork: $!");
7564                          return;
7565                      }
7566                  };
7567                  alarm 0;
7568                  if ($@) {
7569                      kill 9, $pid;
7570                      waitpid $pid, 0;
7571                      my $err = "$@";
7572                      $CPAN::Frontend->myprint($err);
7573                      $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7574                      $@ = "";
7575                      $self->store_persistent_state;
7576                      return $self->goodbye("$system -- TIMED OUT");
7577                  }
7578              }
7579          } else {
7580              if (my $expect_model = $self->_prefs_with_expect("pl")) {
7581                  # XXX probably want to check _should_report here and warn
7582                  # about not being able to use CPAN::Reporter with expect
7583                  $ret = $self->_run_via_expect($system,$expect_model);
7584                  if (! defined $ret
7585                      && $self->{writemakefile}
7586                      && $self->{writemakefile}->failed) {
7587                      # timeout
7588                      return;
7589                  }
7590              }
7591              elsif ( $self->_should_report('pl') ) {
7592                  ($output, $ret) = CPAN::Reporter::record_command($system);
7593                  CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7594              }
7595              else {
7596                  $ret = system($system);
7597              }
7598              if ($ret != 0) {
7599                  $self->{writemakefile} = CPAN::Distrostatus
7600                      ->new("NO '$system' returned status $ret");
7601                  $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7602                  $self->store_persistent_state;
7603                  return $self->goodbye("$system -- NOT OK");
7604              }
7605          }
7606          if (-f "Makefile" || -f "Build") {
7607              $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7608              delete $self->{make_clean}; # if cleaned before, enable next
7609          } else {
7610              my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7611              $self->{writemakefile} = CPAN::Distrostatus
7612                  ->new(qq{NO -- No $makefile created});
7613              $self->store_persistent_state;
7614              return $self->goodbye("$system -- NO $makefile created");
7615          }
7616      }
7617      if ($CPAN::Signal) {
7618          delete $self->{force_update};
7619          return;
7620      }
7621      if (my @prereq = $self->unsat_prereq("later")) {
7622          if ($prereq[0][0] eq "perl") {
7623              my $need = "requires perl '$prereq[0][1]'";
7624              my $id = $self->pretty_id;
7625              $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7626              $self->{make} = CPAN::Distrostatus->new("NO $need");
7627              $self->store_persistent_state;
7628              return $self->goodbye("[prereq] -- NOT OK");
7629          } else {
7630              my $follow = eval { $self->follow_prereqs("later",@prereq); };
7631              if (0) {
7632              } elsif ($follow) {
7633                  # signal success to the queuerunner
7634                  return 1;
7635              } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7636                  $CPAN::Frontend->mywarn($@);
7637                  return $self->goodbye("[depend] -- NOT OK");
7638              }
7639          }
7640      }
7641      if ($CPAN::Signal) {
7642          delete $self->{force_update};
7643          return;
7644      }
7645      if (my $commandline = $self->prefs->{make}{commandline}) {
7646          $system = $commandline;
7647          $ENV{PERL} = CPAN::find_perl;
7648      } else {
7649          if ($self->{modulebuild}) {
7650              unless (-f "Build") {
7651                  my $cwd = CPAN::anycwd();
7652                  $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7653                                          " in cwd[$cwd]. Danger, Will Robinson!\n");
7654                  $CPAN::Frontend->mysleep(5);
7655              }
7656              $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7657          } else {
7658              $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7659          }
7660          $system =~ s/\s+$//;
7661          my $make_arg = $self->make_x_arg("make");
7662          $system = sprintf("%s%s",
7663                            $system,
7664                            $make_arg ? " $make_arg" : "",
7665                           );
7666      }
7667      if (my $env = $self->prefs->{make}{env}) { # overriding the local
7668                                                 # ENV of PL, not the
7669                                                 # outer ENV, but
7670                                                 # unlikely to be a risk
7671          for my $e (keys %$env) {
7672              $ENV{$e} = $env->{$e};
7673          }
7674      }
7675      my $expect_model = $self->_prefs_with_expect("make");
7676      my $want_expect = 0;
7677      if ( $expect_model && @{$expect_model->{talk}} ) {
7678          my $can_expect = $CPAN::META->has_inst("Expect");
7679          if ($can_expect) {
7680              $want_expect = 1;
7681          } else {
7682              $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7683                                      "system()\n");
7684          }
7685      }
7686      my $system_ok;
7687      if ($want_expect) {
7688          # XXX probably want to check _should_report here and
7689          # warn about not being able to use CPAN::Reporter with expect
7690          $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7691      }
7692      elsif ( $self->_should_report('make') ) {
7693          my ($output, $ret) = CPAN::Reporter::record_command($system);
7694          CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7695          $system_ok = ! $ret;
7696      }
7697      else {
7698          $system_ok = system($system) == 0;
7699      }
7700      $self->introduce_myself;
7701      if ( $system_ok ) {
7702          $CPAN::Frontend->myprint("  $system -- OK\n");
7703          $self->{make} = CPAN::Distrostatus->new("YES");
7704      } else {
7705          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7706          $self->{make} = CPAN::Distrostatus->new("NO");
7707          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7708      }
7709      $self->store_persistent_state;
7710  }
7711  
7712  # CPAN::Distribution::goodbye ;
7713  sub goodbye {
7714      my($self,$goodbye) = @_;
7715      my $id = $self->pretty_id;
7716      $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
7717      return;
7718  }
7719  
7720  # CPAN::Distribution::_run_via_expect ;
7721  sub _run_via_expect {
7722      my($self,$system,$expect_model) = @_;
7723      CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7724      if ($CPAN::META->has_inst("Expect")) {
7725          my $expo = Expect->new;  # expo Expect object;
7726          $expo->spawn($system);
7727          $expect_model->{mode} ||= "deterministic";
7728          if ($expect_model->{mode} eq "deterministic") {
7729              return $self->_run_via_expect_deterministic($expo,$expect_model);
7730          } elsif ($expect_model->{mode} eq "anyorder") {
7731              return $self->_run_via_expect_anyorder($expo,$expect_model);
7732          } else {
7733              die "Panic: Illegal expect mode: $expect_model->{mode}";
7734          }
7735      } else {
7736          $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7737          return system($system);
7738      }
7739  }
7740  
7741  sub _run_via_expect_anyorder {
7742      my($self,$expo,$expect_model) = @_;
7743      my $timeout = $expect_model->{timeout} || 5;
7744      my $reuse = $expect_model->{reuse};
7745      my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7746      my $but = "";
7747    EXPECT: while () {
7748          my($eof,$ran_into_timeout);
7749          my @match = $expo->expect($timeout,
7750                                    [ eof => sub {
7751                                          $eof++;
7752                                      } ],
7753                                    [ timeout => sub {
7754                                          $ran_into_timeout++;
7755                                      } ],
7756                                    -re => eval"qr{.}",
7757                                   );
7758          if ($match[2]) {
7759              $but .= $match[2];
7760          }
7761          $but .= $expo->clear_accum;
7762          if ($eof) {
7763              $expo->soft_close;
7764              return $expo->exitstatus();
7765          } elsif ($ran_into_timeout) {
7766              # warn "DEBUG: they are asking a question, but[$but]";
7767              for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7768                  my($next,$send) = @expectacopy[$i,$i+1];
7769                  my $regex = eval "qr{$next}";
7770                  # warn "DEBUG: will compare with regex[$regex].";
7771                  if ($but =~ /$regex/) {
7772                      # warn "DEBUG: will send send[$send]";
7773                      $expo->send($send);
7774                      # never allow reusing an QA pair unless they told us
7775                      splice @expectacopy, $i, 2 unless $reuse;
7776                      next EXPECT;
7777                  }
7778              }
7779              my $why = "could not answer a question during the dialog";
7780              $CPAN::Frontend->mywarn("Failing: $why\n");
7781              $self->{writemakefile} =
7782                  CPAN::Distrostatus->new("NO $why");
7783              return;
7784          }
7785      }
7786  }
7787  
7788  sub _run_via_expect_deterministic {
7789      my($self,$expo,$expect_model) = @_;
7790      my $ran_into_timeout;
7791      my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7792      my $expecta = $expect_model->{talk};
7793    EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7794          my($re,$send) = @$expecta[$i,$i+1];
7795          CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7796          my $regex = eval "qr{$re}";
7797          $expo->expect($timeout,
7798                        [ eof => sub {
7799                              my $but = $expo->clear_accum;
7800                              $CPAN::Frontend->mywarn("EOF (maybe harmless)
7801  expected[$regex]\nbut[$but]\n\n");
7802                              last EXPECT;
7803                          } ],
7804                        [ timeout => sub {
7805                              my $but = $expo->clear_accum;
7806                              $CPAN::Frontend->mywarn("TIMEOUT
7807  expected[$regex]\nbut[$but]\n\n");
7808                              $ran_into_timeout++;
7809                          } ],
7810                        -re => $regex);
7811          if ($ran_into_timeout) {
7812              # note that the caller expects 0 for success
7813              $self->{writemakefile} =
7814                  CPAN::Distrostatus->new("NO timeout during expect dialog");
7815              return;
7816          }
7817          $expo->send($send);
7818      }
7819      $expo->soft_close;
7820      return $expo->exitstatus();
7821  }
7822  
7823  #-> CPAN::Distribution::_validate_distropref
7824  sub _validate_distropref {
7825      my($self,@args) = @_;
7826      if (
7827          $CPAN::META->has_inst("CPAN::Kwalify")
7828          &&
7829          $CPAN::META->has_inst("Kwalify")
7830         ) {
7831          eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7832          if ($@) {
7833              $CPAN::Frontend->mywarn($@);
7834          }
7835      } else {
7836          CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7837      }
7838  }
7839  
7840  #-> CPAN::Distribution::_find_prefs
7841  sub _find_prefs {
7842      my($self) = @_;
7843      my $distroid = $self->pretty_id;
7844      #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7845      my $prefs_dir = $CPAN::Config->{prefs_dir};
7846      return if $prefs_dir =~ /^\s*$/;
7847      eval { File::Path::mkpath($prefs_dir); };
7848      if ($@) {
7849          $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7850      }
7851      my $yaml_module = CPAN::_yaml_module;
7852      my @extensions;
7853      if ($CPAN::META->has_inst($yaml_module)) {
7854          push @extensions, "yml";
7855      } else {
7856          my @fallbacks;
7857          if ($CPAN::META->has_inst("Data::Dumper")) {
7858              push @extensions, "dd";
7859              push @fallbacks, "Data::Dumper";
7860          }
7861          if ($CPAN::META->has_inst("Storable")) {
7862              push @extensions, "st";
7863              push @fallbacks, "Storable";
7864          }
7865          if (@fallbacks) {
7866              local $" = " and ";
7867              unless ($self->{have_complained_about_missing_yaml}++) {
7868                  $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7869                                          "to @fallbacks to read prefs '$prefs_dir'\n");
7870              }
7871          } else {
7872              unless ($self->{have_complained_about_missing_yaml}++) {
7873                  $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7874                                          "read prefs '$prefs_dir'\n");
7875              }
7876          }
7877      }
7878      if (@extensions) {
7879          my $dh = DirHandle->new($prefs_dir)
7880              or die Carp::croak("Couldn't open '$prefs_dir': $!");
7881        DIRENT: for (sort $dh->read) {
7882              next if $_ eq "." || $_ eq "..";
7883              my $exte = join "|", @extensions;
7884              next unless /\.($exte)$/;
7885              my $thisexte = $1;
7886              my $abs = File::Spec->catfile($prefs_dir, $_);
7887              if (-f $abs) {
7888                  #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7889                  my @distropref;
7890                  if ($thisexte eq "yml") {
7891                      # need no eval because if we have no YAML we do not try to read *.yml
7892                      #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7893                      @distropref = @{CPAN->_yaml_loadfile($abs)};
7894                      #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7895                  } elsif ($thisexte eq "dd") {
7896                      package CPAN::Eval;
7897                      no strict;
7898                      open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7899                      local $/;
7900                      my $eval = <FH>;
7901                      close FH;
7902                      eval $eval;
7903                      if ($@) {
7904                          $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7905                      }
7906                      my $i = 1;
7907                      while (${"VAR".$i}) {
7908                          push @distropref, ${"VAR".$i};
7909                          $i++;
7910                      }
7911                  } elsif ($thisexte eq "st") {
7912                      # eval because Storable is never forward compatible
7913                      eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7914                      if ($@) {
7915                          $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7916                                                  "$_, skipping\: $@");
7917                          $CPAN::Frontend->mysleep(4);
7918                          next DIRENT;
7919                      }
7920                  }
7921                  # $DB::single=1;
7922                  #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7923                ELEMENT: for my $y (0..$#distropref) {
7924                      my $distropref = $distropref[$y];
7925                      $self->_validate_distropref($distropref,$abs,$y);
7926                      my $match = $distropref->{match};
7927                      unless ($match) {
7928                          #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7929                          next ELEMENT;
7930                      }
7931                      my $ok = 1;
7932                      # do not take the order of C<keys %$match> because
7933                      # "module" is by far the slowest
7934                      my $saw_valid_subkeys = 0;
7935                      for my $sub_attribute (qw(distribution perl perlconfig module)) {
7936                          next unless exists $match->{$sub_attribute};
7937                          $saw_valid_subkeys++;
7938                          my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7939                          if ($sub_attribute eq "module") {
7940                              my $okm = 0;
7941                              #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7942                              my @modules = $self->containsmods;
7943                              #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7944                            MODULE: for my $module (@modules) {
7945                                  $okm ||= $module =~ /$qr/;
7946                                  last MODULE if $okm;
7947                              }
7948                              $ok &&= $okm;
7949                          } elsif ($sub_attribute eq "distribution") {
7950                              my $okd = $distroid =~ /$qr/;
7951                              $ok &&= $okd;
7952                          } elsif ($sub_attribute eq "perl") {
7953                              my $okp = CPAN::find_perl =~ /$qr/;
7954                              $ok &&= $okp;
7955                          } elsif ($sub_attribute eq "perlconfig") {
7956                              for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7957                                  my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7958                                  # XXX should probably warn if Config does not exist
7959                                  my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7960                                  $ok &&= $okpc;
7961                                  last if $ok == 0;
7962                              }
7963                          } else {
7964                              $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7965                                                     "unknown sub_attribut '$sub_attribute'. ".
7966                                                     "Please ".
7967                                                     "remove, cannot continue.");
7968                          }
7969                          last if $ok == 0; # short circuit
7970                      }
7971                      unless ($saw_valid_subkeys) {
7972                          $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7973                                                 "missing match/* subattribute. ".
7974                                                 "Please ".
7975                                                 "remove, cannot continue.");
7976                      }
7977                      #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7978                      if ($ok) {
7979                          return {
7980                                  prefs => $distropref,
7981                                  prefs_file => $abs,
7982                                  prefs_file_doc => $y,
7983                                 };
7984                      }
7985  
7986                  }
7987              }
7988          }
7989          $dh->close;
7990      }
7991      return;
7992  }
7993  
7994  # CPAN::Distribution::prefs
7995  sub prefs {
7996      my($self) = @_;
7997      if (exists $self->{negative_prefs_cache}
7998          &&
7999          $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8000         ) {
8001          delete $self->{negative_prefs_cache};
8002          delete $self->{prefs};
8003      }
8004      if (exists $self->{prefs}) {
8005          return $self->{prefs}; # XXX comment out during debugging
8006      }
8007      if ($CPAN::Config->{prefs_dir}) {
8008          CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8009          my $prefs = $self->_find_prefs();
8010          $prefs ||= ""; # avoid warning next line
8011          CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8012          if ($prefs) {
8013              for my $x (qw(prefs prefs_file prefs_file_doc)) {
8014                  $self->{$x} = $prefs->{$x};
8015              }
8016              my $bs = sprintf(
8017                               "%s[%s]",
8018                               File::Basename::basename($self->{prefs_file}),
8019                               $self->{prefs_file_doc},
8020                              );
8021              my $filler1 = "_" x 22;
8022              my $filler2 = int(66 - length($bs))/2;
8023              $filler2 = 0 if $filler2 < 0;
8024              $filler2 = " " x $filler2;
8025              $CPAN::Frontend->myprint("
8026  $filler1 D i s t r o P r e f s $filler1
8027  $filler2 $bs $filler2
8028  ");
8029              $CPAN::Frontend->mysleep(1);
8030              return $self->{prefs};
8031          }
8032      }
8033      $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8034      return $self->{prefs} = +{};
8035  }
8036  
8037  # CPAN::Distribution::make_x_arg
8038  sub make_x_arg {
8039      my($self, $whixh) = @_;
8040      my $make_x_arg;
8041      my $prefs = $self->prefs;
8042      if (
8043          $prefs
8044          && exists $prefs->{$whixh}
8045          && exists $prefs->{$whixh}{args}
8046          && $prefs->{$whixh}{args}
8047         ) {
8048          $make_x_arg = join(" ",
8049                             map {CPAN::HandleConfig
8050                                   ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8051                            );
8052      }
8053      my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8054      $make_x_arg ||= $CPAN::Config->{$what};
8055      return $make_x_arg;
8056  }
8057  
8058  # CPAN::Distribution::_make_command
8059  sub _make_command {
8060      my ($self) = @_;
8061      if ($self) {
8062          return
8063              CPAN::HandleConfig
8064                  ->safe_quote(
8065                               CPAN::HandleConfig->prefs_lookup($self,
8066                                                                q{make})
8067                               || $Config::Config{make}
8068                               || 'make'
8069                              );
8070      } else {
8071          # Old style call, without object. Deprecated
8072          Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8073          return
8074            safe_quote(undef,
8075                       CPAN::HandleConfig->prefs_lookup($self,q{make})
8076                       || $CPAN::Config->{make}
8077                       || $Config::Config{make}
8078                       || 'make');
8079      }
8080  }
8081  
8082  #-> sub CPAN::Distribution::follow_prereqs ;
8083  sub follow_prereqs {
8084      my($self) = shift;
8085      my($slot) = shift;
8086      my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8087      return unless @prereq_tuples;
8088      my @prereq = map { $_->[0] } @prereq_tuples;
8089      my $pretty_id = $self->pretty_id;
8090      my %map = (
8091                 b => "build_requires",
8092                 r => "requires",
8093                 c => "commandline",
8094                );
8095      my($filler1,$filler2,$filler3,$filler4);
8096      # $DB::single=1;
8097      my $unsat = "Unsatisfied dependencies detected during";
8098      my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8099      {
8100          my $r = int(($w - length($unsat))/2);
8101          my $l = $w - length($unsat) - $r;
8102          $filler1 = "-"x4 . " "x$l;
8103          $filler2 = " "x$r . "-"x4 . "\n";
8104      }
8105      {
8106          my $r = int(($w - length($pretty_id))/2);
8107          my $l = $w - length($pretty_id) - $r;
8108          $filler3 = "-"x4 . " "x$l;
8109          $filler4 = " "x$r . "-"x4 . "\n";
8110      }
8111      $CPAN::Frontend->
8112          myprint("$filler1 $unsat $filler2".
8113                  "$filler3 $pretty_id $filler4".
8114                  join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8115                 );
8116      my $follow = 0;
8117      if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8118          $follow = 1;
8119      } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8120          my $answer = CPAN::Shell::colorable_makemaker_prompt(
8121  "Shall I follow them and prepend them to the queue
8122  of modules we are processing right now?", "yes");
8123          $follow = $answer =~ /^\s*y/i;
8124      } else {
8125          local($") = ", ";
8126          $CPAN::Frontend->
8127              myprint("  Ignoring dependencies on modules @prereq\n");
8128      }
8129      if ($follow) {
8130          my $id = $self->id;
8131          # color them as dirty
8132          for my $p (@prereq) {
8133              # warn "calling color_cmd_tmps(0,1)";
8134              my $any = CPAN::Shell->expandany($p);
8135              $self->{$slot . "_for"}{$any->id}++;
8136              if ($any) {
8137                  $any->color_cmd_tmps(0,2);
8138              } else {
8139                  $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8140                  $CPAN::Frontend->mysleep(2);
8141              }
8142          }
8143          # queue them and re-queue yourself
8144          CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8145                                 map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8146          $self->{$slot} = "Delayed until after prerequisites";
8147          return 1; # signal success to the queuerunner
8148      }
8149      return;
8150  }
8151  
8152  #-> sub CPAN::Distribution::unsat_prereq ;
8153  # return ([Foo=>1],[Bar=>1.2]) for normal modules
8154  # return ([perl=>5.008]) if we need a newer perl than we are running under
8155  sub unsat_prereq {
8156      my($self,$slot) = @_;
8157      my(%merged,$prereq_pm);
8158      my $prefs_depends = $self->prefs->{depends}||{};
8159      if ($slot eq "configure_requires_later") {
8160          my $meta_yml = $self->parse_meta_yml();
8161          %merged = (%{$meta_yml->{configure_requires}||{}},
8162                     %{$prefs_depends->{configure_requires}||{}});
8163          $prereq_pm = {}; # configure_requires defined as "b"
8164      } elsif ($slot eq "later") {
8165          my $prereq_pm_0 = $self->prereq_pm || {};
8166          for my $reqtype (qw(requires build_requires)) {
8167              $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8168              for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8169                  $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8170              }
8171          }
8172          %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8173      } else {
8174          die "Panic: illegal slot '$slot'";
8175      }
8176      my(@need);
8177      my @merged = %merged;
8178      CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8179    NEED: while (my($need_module, $need_version) = each %merged) {
8180          my($available_version,$available_file,$nmo);
8181          if ($need_module eq "perl") {
8182              $available_version = $];
8183              $available_file = CPAN::find_perl;
8184          } else {
8185              $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8186              next if $nmo->uptodate;
8187              $available_file = $nmo->available_file;
8188  
8189              # if they have not specified a version, we accept any installed one
8190              if (defined $available_file
8191                  and ( # a few quick shortcurcuits
8192                       not defined $need_version
8193                       or $need_version eq '0'    # "==" would trigger warning when not numeric
8194                       or $need_version eq "undef"
8195                      )) {
8196                  next NEED;
8197              }
8198  
8199              $available_version = $nmo->available_version;
8200          }
8201  
8202          # We only want to install prereqs if either they're not installed
8203          # or if the installed version is too old. We cannot omit this
8204          # check, because if 'force' is in effect, nobody else will check.
8205          if (defined $available_file) {
8206              my(@all_requirements) = split /\s*,\s*/, $need_version;
8207              local($^W) = 0;
8208              my $ok = 0;
8209            RQ: for my $rq (@all_requirements) {
8210                  if ($rq =~ s|>=\s*||) {
8211                  } elsif ($rq =~ s|>\s*||) {
8212                      # 2005-12: one user
8213                      if (CPAN::Version->vgt($available_version,$rq)) {
8214                          $ok++;
8215                      }
8216                      next RQ;
8217                  } elsif ($rq =~ s|!=\s*||) {
8218                      # 2005-12: no user
8219                      if (CPAN::Version->vcmp($available_version,$rq)) {
8220                          $ok++;
8221                          next RQ;
8222                      } else {
8223                          last RQ;
8224                      }
8225                  } elsif ($rq =~ m|<=?\s*|) {
8226                      # 2005-12: no user
8227                      $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8228                      $ok++;
8229                      next RQ;
8230                  }
8231                  if (! CPAN::Version->vgt($rq, $available_version)) {
8232                      $ok++;
8233                  }
8234                  CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8235                                      "available_version[%s]rq[%s]ok[%d]",
8236                                      $need_module,
8237                                      $available_file,
8238                                      $available_version,
8239                                      CPAN::Version->readable($rq),
8240                                      $ok,
8241                                     )) if $CPAN::DEBUG;
8242              }
8243              next NEED if $ok == @all_requirements;
8244          }
8245  
8246          if ($need_module eq "perl") {
8247              return ["perl", $need_version];
8248          }
8249          $self->{sponsored_mods}{$need_module} ||= 0;
8250          CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8251          if ($self->{sponsored_mods}{$need_module}++) {
8252              # We have already sponsored it and for some reason it's still
8253              # not available. So we do ... what??
8254  
8255              # if we push it again, we have a potential infinite loop
8256  
8257              # The following "next" was a very problematic construct.
8258              # It helped a lot but broke some day and had to be
8259              # replaced.
8260  
8261              # We must be able to deal with modules that come again and
8262              # again as a prereq and have themselves prereqs and the
8263              # queue becomes long but finally we would find the correct
8264              # order. The RecursiveDependency check should trigger a
8265              # die when it's becoming too weird. Unfortunately removing
8266              # this next breaks many other things.
8267  
8268              # The bug that brought this up is described in Todo under
8269              # "5.8.9 cannot install Compress::Zlib"
8270  
8271              # next; # this is the next that had to go away
8272  
8273              # The following "next NEED" are fine and the error message
8274              # explains well what is going on. For example when the DBI
8275              # fails and consequently DBD::SQLite fails and now we are
8276              # processing CPAN::SQLite. Then we must have a "next" for
8277              # DBD::SQLite. How can we get it and how can we identify
8278              # all other cases we must identify?
8279  
8280              my $do = $nmo->distribution;
8281              next NEED unless $do; # not on CPAN
8282              if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
8283                  $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8284                                          "'$need_module => $need_version' ".
8285                                          "for '$self->{ID}' seems ".
8286                                          "not available according to the indexes\n"
8287                                         );
8288                  next NEED;
8289              }
8290            NOSAYER: for my $nosayer (
8291                                      "unwrapped",
8292                                      "writemakefile",
8293                                      "signature_verify",
8294                                      "make",
8295                                      "make_test",
8296                                      "install",
8297                                      "make_clean",
8298                                     ) {
8299                  if ($do->{$nosayer}) {
8300                      if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8301                          $do->{$nosayer}->failed :
8302                          $do->{$nosayer} =~ /^NO/) {
8303                          if ($nosayer eq "make_test"
8304                              &&
8305                              $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8306                             ) {
8307                              next NOSAYER;
8308                          }
8309                          $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8310                                                  "'$need_module => $need_version' ".
8311                                                  "for '$self->{ID}' failed when ".
8312                                                  "processing '$do->{ID}' with ".
8313                                                  "'$nosayer => $do->{$nosayer}'. Continuing, ".
8314                                                  "but chances to succeed are limited.\n"
8315                                                 );
8316                          next NEED;
8317                      } else { # the other guy succeeded
8318                          if ($nosayer eq "install") {
8319                              # we had this with
8320                              # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8321                              # 2007-03
8322                              $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8323                                                      "'$need_module => $need_version' ".
8324                                                      "for '$self->{ID}' already installed ".
8325                                                      "but installation looks suspicious. ".
8326                                                      "Skipping another installation attempt, ".
8327                                                      "to prevent looping endlessly.\n"
8328                                                     );
8329                              next NEED;
8330                          }
8331                      }
8332                  }
8333              }
8334          }
8335          my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8336          push @need, [$need_module,$needed_as];
8337      }
8338      my @unfolded = map { "[".join(",",@$_)."]" } @need;
8339      CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8340      @need;
8341  }
8342  
8343  #-> sub CPAN::Distribution::read_yaml ;
8344  sub read_yaml {
8345      my($self) = @_;
8346      return $self->{yaml_content} if exists $self->{yaml_content};
8347      my $build_dir = $self->{build_dir};
8348      my $yaml = File::Spec->catfile($build_dir,"META.yml");
8349      $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8350      return unless -f $yaml;
8351      eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8352      if ($@) {
8353          $CPAN::Frontend->mywarn("Could not read ".
8354                                  "'$yaml'. Falling back to other ".
8355                                  "methods to determine prerequisites\n");
8356          return $self->{yaml_content} = undef; # if we die, then we
8357                                                # cannot read YAML's own
8358                                                # META.yml
8359      }
8360      # not "authoritative"
8361      if (not exists $self->{yaml_content}{dynamic_config}
8362          or $self->{yaml_content}{dynamic_config}
8363         ) {
8364          $self->{yaml_content} = undef;
8365      }
8366      $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8367          if $CPAN::DEBUG;
8368      return $self->{yaml_content};
8369  }
8370  
8371  #-> sub CPAN::Distribution::prereq_pm ;
8372  sub prereq_pm {
8373      my($self) = @_;
8374      $self->{prereq_pm_detected} ||= 0;
8375      CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8376      return $self->{prereq_pm} if $self->{prereq_pm_detected};
8377      return unless $self->{writemakefile}  # no need to have succeeded
8378                                            # but we must have run it
8379          || $self->{modulebuild};
8380      CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8381                  $self->{writemakefile}||"",
8382                  $self->{modulebuild}||"",
8383                 ) if $CPAN::DEBUG;
8384      my($req,$breq);
8385      if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8386          $req =  $yaml->{requires} || {};
8387          $breq =  $yaml->{build_requires} || {};
8388          undef $req unless ref $req eq "HASH" && %$req;
8389          if ($req) {
8390              if ($yaml->{generated_by} &&
8391                  $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8392                  my $eummv = do { local $^W = 0; $1+0; };
8393                  if ($eummv < 6.2501) {
8394                      # thanks to Slaven for digging that out: MM before
8395                      # that could be wrong because it could reflect a
8396                      # previous release
8397                      undef $req;
8398                  }
8399              }
8400              my $areq;
8401              my $do_replace;
8402              while (my($k,$v) = each %{$req||{}}) {
8403                  if ($v =~ /\d/) {
8404                      $areq->{$k} = $v;
8405                  } elsif ($k =~ /[A-Za-z]/ &&
8406                           $v =~ /[A-Za-z]/ &&
8407                           $CPAN::META->exists("Module",$v)
8408                          ) {
8409                      $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8410                                              "requires hash: $k => $v; I'll take both ".
8411                                              "key and value as a module name\n");
8412                      $CPAN::Frontend->mysleep(1);
8413                      $areq->{$k} = 0;
8414                      $areq->{$v} = 0;
8415                      $do_replace++;
8416                  }
8417              }
8418              $req = $areq if $do_replace;
8419          }
8420      }
8421      unless ($req || $breq) {
8422          my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8423          my $makefile = File::Spec->catfile($build_dir,"Makefile");
8424          my $fh;
8425          if (-f $makefile
8426              and
8427              $fh = FileHandle->new("<$makefile\0")) {
8428              CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8429              local($/) = "\n";
8430              while (<$fh>) {
8431                  last if /MakeMaker post_initialize section/;
8432                  my($p) = m{^[\#]
8433                             \s+PREREQ_PM\s+=>\s+(.+)
8434                         }x;
8435                  next unless $p;
8436                  # warn "Found prereq expr[$p]";
8437  
8438                  #  Regexp modified by A.Speer to remember actual version of file
8439                  #  PREREQ_PM hash key wants, then add to
8440                  while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8441                      # In case a prereq is mentioned twice, complain.
8442                      if ( defined $req->{$1} ) {
8443                          warn "Warning: PREREQ_PM mentions $1 more than once, ".
8444                              "last mention wins";
8445                      }
8446                      my($m,$n) = ($1,$2);
8447                      if ($n =~ /^q\[(.*?)\]$/) {
8448                          $n = $1;
8449                      }
8450                      $req->{$m} = $n;
8451                  }
8452                  last;
8453              }
8454          }
8455      }
8456      unless ($req || $breq) {
8457          my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8458          my $buildfile = File::Spec->catfile($build_dir,"Build");
8459          if (-f $buildfile) {
8460              CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8461              my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8462              if (-f $build_prereqs) {
8463                  CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8464                  my $content = do { local *FH;
8465                                     open FH, $build_prereqs
8466                                         or $CPAN::Frontend->mydie("Could not open ".
8467                                                                   "'$build_prereqs': $!");
8468                                     local $/;
8469                                     <FH>;
8470                                 };
8471                  my $bphash = eval $content;
8472                  if ($@) {
8473                  } else {
8474                      $req  = $bphash->{requires} || +{};
8475                      $breq = $bphash->{build_requires} || +{};
8476                  }
8477              }
8478          }
8479      }
8480      if (-f "Build.PL"
8481          && ! -f "Makefile.PL"
8482          && ! exists $req->{"Module::Build"}
8483          && ! $CPAN::META->has_inst("Module::Build")) {
8484          $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8485                                  "undeclared prerequisite.\n".
8486                                  "  Adding it now as such.\n"
8487                                 );
8488          $CPAN::Frontend->mysleep(5);
8489          $req->{"Module::Build"} = 0;
8490          delete $self->{writemakefile};
8491      }
8492      if ($req || $breq) {
8493          $self->{prereq_pm_detected}++;
8494          return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8495      }
8496  }
8497  
8498  #-> sub CPAN::Distribution::test ;
8499  sub test {
8500      my($self) = @_;
8501      if (my $goto = $self->prefs->{goto}) {
8502          return $self->goto($goto);
8503      }
8504      $self->make;
8505      if ($CPAN::Signal) {
8506        delete $self->{force_update};
8507        return;
8508      }
8509      # warn "XDEBUG: checking for notest: $self->{notest} $self";
8510      if ($self->{notest}) {
8511          $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8512          return 1;
8513      }
8514  
8515      my $make = $self->{modulebuild} ? "Build" : "make";
8516  
8517      local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8518                             ? $ENV{PERL5LIB}
8519                             : ($ENV{PERLLIB} || "");
8520  
8521      $CPAN::META->set_perl5lib;
8522      local $ENV{MAKEFLAGS}; # protect us from outer make calls
8523  
8524      $CPAN::Frontend->myprint("Running $make test\n");
8525  
8526    EXCUSE: {
8527          my @e;
8528          if ($self->{make} or $self->{later}) {
8529              # go ahead
8530          } else {
8531              push @e,
8532                  "Make had some problems, won't test";
8533          }
8534  
8535          exists $self->{make} and
8536              (
8537               UNIVERSAL::can($self->{make},"failed") ?
8538               $self->{make}->failed :
8539               $self->{make} =~ /^NO/
8540              ) and push @e, "Can't test without successful make";
8541          $self->{badtestcnt} ||= 0;
8542          if ($self->{badtestcnt} > 0) {
8543              require Data::Dumper;
8544              CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8545              push @e, "Won't repeat unsuccessful test during this command";
8546          }
8547  
8548          push @e, $self->{later} if $self->{later};
8549          push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8550  
8551          if (exists $self->{build_dir}) {
8552              if (exists $self->{make_test}) {
8553                  if (
8554                      UNIVERSAL::can($self->{make_test},"failed") ?
8555                      $self->{make_test}->failed :
8556                      $self->{make_test} =~ /^NO/
8557                     ) {
8558                      if (
8559                          UNIVERSAL::can($self->{make_test},"commandid")
8560                          &&
8561                          $self->{make_test}->commandid == $CPAN::CurrentCommandId
8562                         ) {
8563                          push @e, "Has already been tested within this command";
8564                      }
8565                  } else {
8566                      push @e, "Has already been tested successfully";
8567                  }
8568              }
8569          } elsif (!@e) {
8570              push @e, "Has no own directory";
8571          }
8572          $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8573          unless (chdir $self->{build_dir}) {
8574              push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8575          }
8576          $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8577      }
8578      $self->debug("Changed directory to $self->{build_dir}")
8579          if $CPAN::DEBUG;
8580  
8581      if ($^O eq 'MacOS') {
8582          Mac::BuildTools::make_test($self);
8583          return;
8584      }
8585  
8586      if ($self->{modulebuild}) {
8587          my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8588          if (CPAN::Version->vlt($v,2.62)) {
8589              $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8590    '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8591              $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8592              return;
8593          }
8594      }
8595  
8596      my $system;
8597      my $prefs_test = $self->prefs->{test};
8598      if (my $commandline
8599          = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
8600          $system = $commandline;
8601          $ENV{PERL} = CPAN::find_perl;
8602      } elsif ($self->{modulebuild}) {
8603          $system = sprintf "%s test", $self->_build_command();
8604      } else {
8605          $system = join " ", $self->_make_command(), "test";
8606      }
8607      my $make_test_arg = $self->make_x_arg("test");
8608      $system = sprintf("%s%s",
8609                        $system,
8610                        $make_test_arg ? " $make_test_arg" : "",
8611                       );
8612      my($tests_ok);
8613      my %env;
8614      while (my($k,$v) = each %ENV) {
8615          next unless defined $v;
8616          $env{$k} = $v;
8617      }
8618      local %ENV = %env;
8619      if (my $env = $self->prefs->{test}{env}) {
8620          for my $e (keys %$env) {
8621              $ENV{$e} = $env->{$e};
8622          }
8623      }
8624      my $expect_model = $self->_prefs_with_expect("test");
8625      my $want_expect = 0;
8626      if ( $expect_model && @{$expect_model->{talk}} ) {
8627          my $can_expect = $CPAN::META->has_inst("Expect");
8628          if ($can_expect) {
8629              $want_expect = 1;
8630          } else {
8631              $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8632                                      "testing without\n");
8633          }
8634      }
8635      if ($want_expect) {
8636          if ($self->_should_report('test')) {
8637              $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8638                                      "not supported when distroprefs specify ".
8639                                      "an interactive test\n");
8640          }
8641          $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8642      } elsif ( $self->_should_report('test') ) {
8643          $tests_ok = CPAN::Reporter::test($self, $system);
8644      } else {
8645          $tests_ok = system($system) == 0;
8646      }
8647      $self->introduce_myself;
8648      if ( $tests_ok ) {
8649          {
8650              my @prereq;
8651  
8652              # local $CPAN::DEBUG = 16; # Distribution
8653              for my $m (keys %{$self->{sponsored_mods}}) {
8654                  next unless $self->{sponsored_mods}{$m} > 0;
8655                  my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8656                  # XXX we need available_version which reflects
8657                  # $ENV{PERL5LIB} so that already tested but not yet
8658                  # installed modules are counted.
8659                  my $available_version = $m_obj->available_version;
8660                  my $available_file = $m_obj->available_file;
8661                  if ($available_version &&
8662                      !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8663                     ) {
8664                      CPAN->debug("m[$m] good enough available_version[$available_version]")
8665                          if $CPAN::DEBUG;
8666                  } elsif ($available_file
8667                           && (
8668                               !$self->{prereq_pm}{$m}
8669                               ||
8670                               $self->{prereq_pm}{$m} == 0
8671                              )
8672                          ) {
8673                      # lex Class::Accessor::Chained::Fast which has no $VERSION
8674                      CPAN->debug("m[$m] have available_file[$available_file]")
8675                          if $CPAN::DEBUG;
8676                  } else {
8677                      push @prereq, $m;
8678                  }
8679              }
8680              if (@prereq) {
8681                  my $cnt = @prereq;
8682                  my $which = join ",", @prereq;
8683                  my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8684                      "$cnt dependencies missing ($which)";
8685                  $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8686                  $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8687                  $self->store_persistent_state;
8688                  return $self->goodbye("[dependencies] -- NA");
8689              }
8690          }
8691  
8692          $CPAN::Frontend->myprint("  $system -- OK\n");
8693          $self->{make_test} = CPAN::Distrostatus->new("YES");
8694          $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8695          # probably impossible to need the next line because badtestcnt
8696          # has a lifespan of one command
8697          delete $self->{badtestcnt};
8698      } else {
8699          $self->{make_test} = CPAN::Distrostatus->new("NO");
8700          $self->{badtestcnt}++;
8701          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8702          CPAN::Shell->optprint
8703                ("hint",
8704                 sprintf
8705                 ("//hint// to see the cpan-testers results for installing this module, try:
8706    reports %s\n",
8707                  $self->pretty_id));
8708      }
8709      $self->store_persistent_state;
8710  }
8711  
8712  sub _prefs_with_expect {
8713      my($self,$where) = @_;
8714      return unless my $prefs = $self->prefs;
8715      return unless my $where_prefs = $prefs->{$where};
8716      if ($where_prefs->{expect}) {
8717          return {
8718                  mode => "deterministic",
8719                  timeout => 15,
8720                  talk => $where_prefs->{expect},
8721                 };
8722      } elsif ($where_prefs->{"eexpect"}) {
8723          return $where_prefs->{"eexpect"};
8724      }
8725      return;
8726  }
8727  
8728  #-> sub CPAN::Distribution::clean ;
8729  sub clean {
8730      my($self) = @_;
8731      my $make = $self->{modulebuild} ? "Build" : "make";
8732      $CPAN::Frontend->myprint("Running $make clean\n");
8733      unless (exists $self->{archived}) {
8734          $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8735                                  "/untarred, nothing done\n");
8736          return 1;
8737      }
8738      unless (exists $self->{build_dir}) {
8739          $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8740          return 1;
8741      }
8742      if (exists $self->{writemakefile}
8743          and $self->{writemakefile}->failed
8744         ) {
8745          $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8746          return 1;
8747      }
8748    EXCUSE: {
8749          my @e;
8750          exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8751              push @e, "make clean already called once";
8752          $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8753      }
8754      chdir $self->{build_dir} or
8755          Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8756      $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8757  
8758      if ($^O eq 'MacOS') {
8759          Mac::BuildTools::make_clean($self);
8760          return;
8761      }
8762  
8763      my $system;
8764      if ($self->{modulebuild}) {
8765          unless (-f "Build") {
8766              my $cwd = CPAN::anycwd();
8767              $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8768                                      " in cwd[$cwd]. Danger, Will Robinson!");
8769              $CPAN::Frontend->mysleep(5);
8770          }
8771          $system = sprintf "%s clean", $self->_build_command();
8772      } else {
8773          $system  = join " ", $self->_make_command(), "clean";
8774      }
8775      my $system_ok = system($system) == 0;
8776      $self->introduce_myself;
8777      if ( $system_ok ) {
8778        $CPAN::Frontend->myprint("  $system -- OK\n");
8779  
8780        # $self->force;
8781  
8782        # Jost Krieger pointed out that this "force" was wrong because
8783        # it has the effect that the next "install" on this distribution
8784        # will untar everything again. Instead we should bring the
8785        # object's state back to where it is after untarring.
8786  
8787        for my $k (qw(
8788                      force_update
8789                      install
8790                      writemakefile
8791                      make
8792                      make_test
8793                     )) {
8794            delete $self->{$k};
8795        }
8796        $self->{make_clean} = CPAN::Distrostatus->new("YES");
8797  
8798      } else {
8799        # Hmmm, what to do if make clean failed?
8800  
8801        $self->{make_clean} = CPAN::Distrostatus->new("NO");
8802        $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8803  
8804        # 2006-02-27: seems silly to me to force a make now
8805        # $self->force("make"); # so that this directory won't be used again
8806  
8807      }
8808      $self->store_persistent_state;
8809  }
8810  
8811  #-> sub CPAN::Distribution::goto ;
8812  sub goto {
8813      my($self,$goto) = @_;
8814      $goto = $self->normalize($goto);
8815      my $why = sprintf(
8816                        "Goto '$goto' via prefs file '%s' doc %d",
8817                        $self->{prefs_file},
8818                        $self->{prefs_file_doc},
8819                       );
8820      $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8821      # 2007-07-16 akoenig : Better than NA would be if we could inherit
8822      # the status of the $goto distro but given the exceptional nature
8823      # of 'goto' I feel reluctant to implement it
8824      my $goodbye_message = "[goto] -- NA $why";
8825      $self->goodbye($goodbye_message);
8826  
8827      # inject into the queue
8828  
8829      CPAN::Queue->delete($self->id);
8830      CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
8831  
8832      # and run where we left off
8833  
8834      my($method) = (caller(1))[3];
8835      CPAN->instance("CPAN::Distribution",$goto)->$method();
8836      CPAN::Queue->delete_first($goto);
8837  }
8838  
8839  #-> sub CPAN::Distribution::install ;
8840  sub install {
8841      my($self) = @_;
8842      if (my $goto = $self->prefs->{goto}) {
8843          return $self->goto($goto);
8844      }
8845      # $DB::single=1;
8846      unless ($self->{badtestcnt}) {
8847          $self->test;
8848      }
8849      if ($CPAN::Signal) {
8850        delete $self->{force_update};
8851        return;
8852      }
8853      my $make = $self->{modulebuild} ? "Build" : "make";
8854      $CPAN::Frontend->myprint("Running $make install\n");
8855    EXCUSE: {
8856          my @e;
8857          if ($self->{make} or $self->{later}) {
8858              # go ahead
8859          } else {
8860              push @e,
8861                  "Make had some problems, won't install";
8862          }
8863  
8864          exists $self->{make} and
8865              (
8866               UNIVERSAL::can($self->{make},"failed") ?
8867               $self->{make}->failed :
8868               $self->{make} =~ /^NO/
8869              ) and
8870              push @e, "Make had returned bad status, install seems impossible";
8871  
8872          if (exists $self->{build_dir}) {
8873          } elsif (!@e) {
8874              push @e, "Has no own directory";
8875          }
8876  
8877          if (exists $self->{make_test} and
8878              (
8879               UNIVERSAL::can($self->{make_test},"failed") ?
8880               $self->{make_test}->failed :
8881               $self->{make_test} =~ /^NO/
8882              )) {
8883              if ($self->{force_update}) {
8884                  $self->{make_test}->text("FAILED but failure ignored because ".
8885                                           "'force' in effect");
8886              } else {
8887                  push @e, "make test had returned bad status, ".
8888                      "won't install without force"
8889              }
8890          }
8891          if (exists $self->{install}) {
8892              if (UNIVERSAL::can($self->{install},"text") ?
8893                  $self->{install}->text eq "YES" :
8894                  $self->{install} =~ /^YES/
8895                 ) {
8896                  $CPAN::Frontend->myprint("  Already done\n");
8897                  $CPAN::META->is_installed($self->{build_dir});
8898                  return 1;
8899              } else {
8900                  # comment in Todo on 2006-02-11; maybe retry?
8901                  push @e, "Already tried without success";
8902              }
8903          }
8904  
8905          push @e, $self->{later} if $self->{later};
8906          push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8907  
8908          $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8909          unless (chdir $self->{build_dir}) {
8910              push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8911          }
8912          $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8913      }
8914      $self->debug("Changed directory to $self->{build_dir}")
8915          if $CPAN::DEBUG;
8916  
8917      if ($^O eq 'MacOS') {
8918          Mac::BuildTools::make_install($self);
8919          return;
8920      }
8921  
8922      my $system;
8923      if (my $commandline = $self->prefs->{install}{commandline}) {
8924          $system = $commandline;
8925          $ENV{PERL} = CPAN::find_perl;
8926      } elsif ($self->{modulebuild}) {
8927          my($mbuild_install_build_command) =
8928              exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8929                  $CPAN::Config->{mbuild_install_build_command} ?
8930                      $CPAN::Config->{mbuild_install_build_command} :
8931                          $self->_build_command();
8932          $system = sprintf("%s install %s",
8933                            $mbuild_install_build_command,
8934                            $CPAN::Config->{mbuild_install_arg},
8935                           );
8936      } else {
8937          my($make_install_make_command) =
8938              CPAN::HandleConfig->prefs_lookup($self,
8939                                               q{make_install_make_command})
8940                    || $self->_make_command();
8941          $system = sprintf("%s install %s",
8942                            $make_install_make_command,
8943                            $CPAN::Config->{make_install_arg},
8944                           );
8945      }
8946  
8947      my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8948      my $brip = CPAN::HandleConfig->prefs_lookup($self,
8949                                                  q{build_requires_install_policy});
8950      $brip ||="ask/yes";
8951      my $id = $self->id;
8952      my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8953      my $want_install = "yes";
8954      if ($reqtype eq "b") {
8955          if ($brip eq "no") {
8956              $want_install = "no";
8957          } elsif ($brip =~ m|^ask/(.+)|) {
8958              my $default = $1;
8959              $default = "yes" unless $default =~ /^(y|n)/i;
8960              $want_install =
8961                  CPAN::Shell::colorable_makemaker_prompt
8962                        ("$id is just needed temporarily during building or testing. ".
8963                         "Do you want to install it permanently? (Y/n)",
8964                         $default);
8965          }
8966      }
8967      unless ($want_install =~ /^y/i) {
8968          my $is_only = "is only 'build_requires'";
8969          $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8970          $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8971          delete $self->{force_update};
8972          return;
8973      }
8974      local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8975                             ? $ENV{PERL5LIB}
8976                             : ($ENV{PERLLIB} || "");
8977  
8978      $CPAN::META->set_perl5lib;
8979      my($pipe) = FileHandle->new("$system $stderr |");
8980      my($makeout) = "";
8981      while (<$pipe>) {
8982          print $_; # intentionally NOT use Frontend->myprint because it
8983                    # looks irritating when we markup in color what we
8984                    # just pass through from an external program
8985          $makeout .= $_;
8986      }
8987      $pipe->close;
8988      my $close_ok = $? == 0;
8989      $self->introduce_myself;
8990      if ( $close_ok ) {
8991          $CPAN::Frontend->myprint("  $system -- OK\n");
8992          $CPAN::META->is_installed($self->{build_dir});
8993          $self->{install} = CPAN::Distrostatus->new("YES");
8994      } else {
8995          $self->{install} = CPAN::Distrostatus->new("NO");
8996          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8997          my $mimc =
8998              CPAN::HandleConfig->prefs_lookup($self,
8999                                               q{make_install_make_command});
9000          if (
9001              $makeout =~ /permission/s
9002              && $> > 0
9003              && (
9004                  ! $mimc
9005                  || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9006                                                                q{make}))
9007                 )
9008             ) {
9009              $CPAN::Frontend->myprint(
9010                                       qq{----\n}.
9011                                       qq{  You may have to su }.
9012                                       qq{to root to install the package\n}.
9013                                       qq{  (Or you may want to run something like\n}.
9014                                       qq{    o conf make_install_make_command 'sudo make'\n}.
9015                                       qq{  to raise your permissions.}
9016                                      );
9017          }
9018      }
9019      delete $self->{force_update};
9020      # $DB::single = 1;
9021      $self->store_persistent_state;
9022  }
9023  
9024  sub introduce_myself {
9025      my($self) = @_;
9026      $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
9027  }
9028  
9029  #-> sub CPAN::Distribution::dir ;
9030  sub dir {
9031      shift->{build_dir};
9032  }
9033  
9034  #-> sub CPAN::Distribution::perldoc ;
9035  sub perldoc {
9036      my($self) = @_;
9037  
9038      my($dist) = $self->id;
9039      my $package = $self->called_for;
9040  
9041      $self->_display_url( $CPAN::Defaultdocs . $package );
9042  }
9043  
9044  #-> sub CPAN::Distribution::_check_binary ;
9045  sub _check_binary {
9046      my ($dist,$shell,$binary) = @_;
9047      my ($pid,$out);
9048  
9049      $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9050        if $CPAN::DEBUG;
9051  
9052      if ($CPAN::META->has_inst("File::Which")) {
9053          return File::Which::which($binary);
9054      } else {
9055          local *README;
9056          $pid = open README, "which $binary|"
9057              or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9058          return unless $pid;
9059          while (<README>) {
9060              $out .= $_;
9061          }
9062          close README
9063              or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9064                  and return;
9065      }
9066  
9067      $CPAN::Frontend->myprint(qq{   + $out \n})
9068        if $CPAN::DEBUG && $out;
9069  
9070      return $out;
9071  }
9072  
9073  #-> sub CPAN::Distribution::_display_url ;
9074  sub _display_url {
9075      my($self,$url) = @_;
9076      my($res,$saved_file,$pid,$out);
9077  
9078      $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9079        if $CPAN::DEBUG;
9080  
9081      # should we define it in the config instead?
9082      my $html_converter = "html2text.pl";
9083  
9084      my $web_browser = $CPAN::Config->{'lynx'} || undef;
9085      my $web_browser_out = $web_browser
9086          ? CPAN::Distribution->_check_binary($self,$web_browser)
9087          : undef;
9088  
9089      if ($web_browser_out) {
9090          # web browser found, run the action
9091          my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9092          $CPAN::Frontend->myprint(qq{system[$browser $url]})
9093              if $CPAN::DEBUG;
9094          $CPAN::Frontend->myprint(qq{
9095  Displaying URL
9096    $url
9097  with browser $browser
9098  });
9099          $CPAN::Frontend->mysleep(1);
9100          system("$browser $url");
9101          if ($saved_file) { 1 while unlink($saved_file) }
9102      } else {
9103          # web browser not found, let's try text only
9104          my $html_converter_out =
9105              CPAN::Distribution->_check_binary($self,$html_converter);
9106          $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9107  
9108          if ($html_converter_out ) {
9109              # html2text found, run it
9110              $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9111              $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9112                  unless defined($saved_file);
9113  
9114              local *README;
9115              $pid = open README, "$html_converter $saved_file |"
9116                  or $CPAN::Frontend->mydie(qq{
9117  Could not fork '$html_converter $saved_file': $!});
9118              my($fh,$filename);
9119              if ($CPAN::META->has_usable("File::Temp")) {
9120                  $fh = File::Temp->new(
9121                                        dir      => File::Spec->tmpdir,
9122                                        template => 'cpan_htmlconvert_XXXX',
9123                                        suffix => '.txt',
9124                                        unlink => 0,
9125                                       );
9126                  $filename = $fh->filename;
9127              } else {
9128                  $filename = "cpan_htmlconvert_$$.txt";
9129                  $fh = FileHandle->new();
9130                  open $fh, ">$filename" or die;
9131              }
9132              while (<README>) {
9133                  $fh->print($_);
9134              }
9135              close README or
9136                  $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9137              my $tmpin = $fh->filename;
9138              $CPAN::Frontend->myprint(sprintf(qq{
9139  Run '%s %s' and
9140  saved output to %s\n},
9141                                               $html_converter,
9142                                               $saved_file,
9143                                               $tmpin,
9144                                              )) if $CPAN::DEBUG;
9145              close $fh;
9146              local *FH;
9147              open FH, $tmpin
9148                  or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9149              my $fh_pager = FileHandle->new;
9150              local($SIG{PIPE}) = "IGNORE";
9151              my $pager = $CPAN::Config->{'pager'} || "cat";
9152              $fh_pager->open("|$pager")
9153                  or $CPAN::Frontend->mydie(qq{
9154  Could not open pager '$pager': $!});
9155              $CPAN::Frontend->myprint(qq{
9156  Displaying URL
9157    $url
9158  with pager "$pager"
9159  });
9160              $CPAN::Frontend->mysleep(1);
9161              $fh_pager->print(<FH>);
9162              $fh_pager->close;
9163          } else {
9164              # coldn't find the web browser or html converter
9165              $CPAN::Frontend->myprint(qq{
9166  You need to install lynx or $html_converter to use this feature.});
9167          }
9168      }
9169  }
9170  
9171  #-> sub CPAN::Distribution::_getsave_url ;
9172  sub _getsave_url {
9173      my($dist, $shell, $url) = @_;
9174  
9175      $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9176        if $CPAN::DEBUG;
9177  
9178      my($fh,$filename);
9179      if ($CPAN::META->has_usable("File::Temp")) {
9180          $fh = File::Temp->new(
9181                                dir      => File::Spec->tmpdir,
9182                                template => "cpan_getsave_url_XXXX",
9183                                suffix => ".html",
9184                                unlink => 0,
9185                               );
9186          $filename = $fh->filename;
9187      } else {
9188          $fh = FileHandle->new;
9189          $filename = "cpan_getsave_url_$$.html";
9190      }
9191      my $tmpin = $filename;
9192      if ($CPAN::META->has_usable('LWP')) {
9193          $CPAN::Frontend->myprint("Fetching with LWP:
9194    $url
9195  ");
9196          my $Ua;
9197          CPAN::LWP::UserAgent->config;
9198          eval { $Ua = CPAN::LWP::UserAgent->new; };
9199          if ($@) {
9200              $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9201              return;
9202          } else {
9203              my($var);
9204              $Ua->proxy('http', $var)
9205                  if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9206              $Ua->no_proxy($var)
9207                  if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9208          }
9209  
9210          my $req = HTTP::Request->new(GET => $url);
9211          $req->header('Accept' => 'text/html');
9212          my $res = $Ua->request($req);
9213          if ($res->is_success) {
9214              $CPAN::Frontend->myprint(" + request successful.\n")
9215                  if $CPAN::DEBUG;
9216              print $fh $res->content;
9217              close $fh;
9218              $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9219                  if $CPAN::DEBUG;
9220              return $tmpin;
9221          } else {
9222              $CPAN::Frontend->myprint(sprintf(
9223                                               "LWP failed with code[%s], message[%s]\n",
9224                                               $res->code,
9225                                               $res->message,
9226                                              ));
9227              return;
9228          }
9229      } else {
9230          $CPAN::Frontend->mywarn("  LWP not available\n");
9231          return;
9232      }
9233  }
9234  
9235  #-> sub CPAN::Distribution::_build_command
9236  sub _build_command {
9237      my($self) = @_;
9238      if ($^O eq "MSWin32") { # special code needed at least up to
9239                              # Module::Build 0.2611 and 0.2706; a fix
9240                              # in M:B has been promised 2006-01-30
9241          my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9242          return "$perl ./Build";
9243      }
9244      return "./Build";
9245  }
9246  
9247  #-> sub CPAN::Distribution::_should_report
9248  sub _should_report {
9249      my($self, $phase) = @_;
9250      die "_should_report() requires a 'phase' argument"
9251          if ! defined $phase;
9252  
9253      # configured
9254      my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9255                                                         q{test_report});
9256      return unless $test_report;
9257  
9258      # don't repeat if we cached a result
9259      return $self->{should_report}
9260          if exists $self->{should_report};
9261  
9262      # available
9263      if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9264          $CPAN::Frontend->mywarn(
9265              "CPAN::Reporter not installed.  No reports will be sent.\n"
9266          );
9267          return $self->{should_report} = 0;
9268      }
9269  
9270      # capable
9271      my $crv = CPAN::Reporter->VERSION;
9272      if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9273          # don't cache $self->{should_report} -- need to check each phase
9274          if ( $phase eq 'test' ) {
9275              return 1;
9276          }
9277          else {
9278              $CPAN::Frontend->mywarn(
9279                  "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9280                  "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9281              );
9282              return;
9283          }
9284      }
9285  
9286      # appropriate
9287      if ($self->is_dot_dist) {
9288          $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9289                                  "for local directories\n");
9290          return $self->{should_report} = 0;
9291      }
9292      if ($self->prefs->{patches}
9293          &&
9294          @{$self->prefs->{patches}}
9295          &&
9296          $self->{patched}
9297         ) {
9298          $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9299                                  "when the source has been patched\n");
9300          return $self->{should_report} = 0;
9301      }
9302  
9303      # proceed and cache success
9304      return $self->{should_report} = 1;
9305  }
9306  
9307  #-> sub CPAN::Distribution::reports
9308  sub reports {
9309      my($self) = @_;
9310      my $pathname = $self->id;
9311      $CPAN::Frontend->myprint("Distribution: $pathname\n");
9312  
9313      unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9314          $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9315      }
9316      unless ($CPAN::META->has_usable("LWP")) {
9317          $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9318      }
9319      unless ($CPAN::META->has_usable("File::Temp")) {
9320          $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9321      }
9322  
9323      my $d = CPAN::DistnameInfo->new($pathname);
9324  
9325      my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9326      my $version   = $d->version;   # "0.02"
9327      my $maturity  = $d->maturity;  # "released"
9328      my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9329      my $cpanid    = $d->cpanid;    # "GBARR"
9330      my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9331  
9332      my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9333  
9334      CPAN::LWP::UserAgent->config;
9335      my $Ua;
9336      eval { $Ua = CPAN::LWP::UserAgent->new; };
9337      if ($@) {
9338          $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9339      }
9340      $CPAN::Frontend->myprint("Fetching '$url'...");
9341      my $resp = $Ua->get($url);
9342      unless ($resp->is_success) {
9343          $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9344      }
9345      $CPAN::Frontend->myprint("DONE\n\n");
9346      my $yaml = $resp->content;
9347      # was fuer ein Umweg!
9348      my $fh = File::Temp->new(
9349                               dir      => File::Spec->tmpdir,
9350                               template => 'cpan_reports_XXXX',
9351                               suffix => '.yaml',
9352                               unlink => 0,
9353                              );
9354      my $tfilename = $fh->filename;
9355      print $fh $yaml;
9356      close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9357      my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9358      unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9359      my %other_versions;
9360      my $this_version_seen;
9361      for my $rep (@$unserialized) {
9362          my $rversion = $rep->{version};
9363          if ($rversion eq $version) {
9364              unless ($this_version_seen++) {
9365                  $CPAN::Frontend->myprint ("$rep->{version}:\n");
9366              }
9367              $CPAN::Frontend->myprint
9368                  (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9369                           $rep->{archname} eq $Config::Config{archname}?"*":"",
9370                           $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9371                           $rep->{action},
9372                           $rep->{perl},
9373                           ucfirst $rep->{osname},
9374                           $rep->{osvers},
9375                           $rep->{archname},
9376                          ));
9377          } else {
9378              $other_versions{$rep->{version}}++;
9379          }
9380      }
9381      unless ($this_version_seen) {
9382          $CPAN::Frontend->myprint("No reports found for version '$version'
9383  Reports for other versions:\n");
9384          for my $v (sort keys %other_versions) {
9385              $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9386          }
9387      }
9388      $url =~ s/\.yaml/.html/;
9389      $CPAN::Frontend->myprint("See $url for details\n");
9390  }
9391  
9392  package CPAN::Bundle;
9393  use strict;
9394  
9395  sub look {
9396      my $self = shift;
9397      $CPAN::Frontend->myprint($self->as_string);
9398  }
9399  
9400  #-> CPAN::Bundle::undelay
9401  sub undelay {
9402      my $self = shift;
9403      delete $self->{later};
9404      for my $c ( $self->contains ) {
9405          my $obj = CPAN::Shell->expandany($c) or next;
9406          $obj->undelay;
9407      }
9408  }
9409  
9410  # mark as dirty/clean
9411  #-> sub CPAN::Bundle::color_cmd_tmps ;
9412  sub color_cmd_tmps {
9413      my($self) = shift;
9414      my($depth) = shift || 0;
9415      my($color) = shift || 0;
9416      my($ancestors) = shift || [];
9417      # a module needs to recurse to its cpan_file, a distribution needs
9418      # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9419  
9420      return if exists $self->{incommandcolor}
9421          && $color==1
9422          && $self->{incommandcolor}==$color;
9423      if ($depth>=$CPAN::MAX_RECURSION) {
9424          die(CPAN::Exception::RecursiveDependency->new($ancestors));
9425      }
9426      # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9427  
9428      for my $c ( $self->contains ) {
9429          my $obj = CPAN::Shell->expandany($c) or next;
9430          CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9431          $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9432      }
9433      # never reached code?
9434      #if ($color==0) {
9435        #delete $self->{badtestcnt};
9436      #}
9437      $self->{incommandcolor} = $color;
9438  }
9439  
9440  #-> sub CPAN::Bundle::as_string ;
9441  sub as_string {
9442      my($self) = @_;
9443      $self->contains;
9444      # following line must be "=", not "||=" because we have a moving target
9445      $self->{INST_VERSION} = $self->inst_version;
9446      return $self->SUPER::as_string;
9447  }
9448  
9449  #-> sub CPAN::Bundle::contains ;
9450  sub contains {
9451      my($self) = @_;
9452      my($inst_file) = $self->inst_file || "";
9453      my($id) = $self->id;
9454      $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9455      if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9456          undef $inst_file;
9457      }
9458      unless ($inst_file) {
9459          # Try to get at it in the cpan directory
9460          $self->debug("no inst_file") if $CPAN::DEBUG;
9461          my $cpan_file;
9462          $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9463                $cpan_file = $self->cpan_file;
9464          if ($cpan_file eq "N/A") {
9465              $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9466    Maybe stale symlink? Maybe removed during session? Giving up.\n");
9467          }
9468          my $dist = $CPAN::META->instance('CPAN::Distribution',
9469                                           $self->cpan_file);
9470          $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9471          $dist->get;
9472          $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9473          my($todir) = $CPAN::Config->{'cpan_home'};
9474          my(@me,$from,$to,$me);
9475          @me = split /::/, $self->id;
9476          $me[-1] .= ".pm";
9477          $me = File::Spec->catfile(@me);
9478          $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9479          $to = File::Spec->catfile($todir,$me);
9480          File::Path::mkpath(File::Basename::dirname($to));
9481          File::Copy::copy($from, $to)
9482                or Carp::confess("Couldn't copy $from to $to: $!");
9483          $inst_file = $to;
9484      }
9485      my @result;
9486      my $fh = FileHandle->new;
9487      local $/ = "\n";
9488      open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9489      my $in_cont = 0;
9490      $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9491      while (<$fh>) {
9492          $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9493              m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9494          next unless $in_cont;
9495          next if /^=/;
9496          s/\#.*//;
9497          next if /^\s+$/;
9498          chomp;
9499          push @result, (split " ", $_, 2)[0];
9500      }
9501      close $fh;
9502      delete $self->{STATUS};
9503      $self->{CONTAINS} = \@result;
9504      $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9505      unless (@result) {
9506          $CPAN::Frontend->mywarn(qq{
9507  The bundle file "$inst_file" may be a broken
9508  bundlefile. It seems not to contain any bundle definition.
9509  Please check the file and if it is bogus, please delete it.
9510  Sorry for the inconvenience.
9511  });
9512      }
9513      @result;
9514  }
9515  
9516  #-> sub CPAN::Bundle::find_bundle_file
9517  # $where is in local format, $what is in unix format
9518  sub find_bundle_file {
9519      my($self,$where,$what) = @_;
9520      $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9521  ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9522  ###    my $bu = File::Spec->catfile($where,$what);
9523  ###    return $bu if -f $bu;
9524      my $manifest = File::Spec->catfile($where,"MANIFEST");
9525      unless (-f $manifest) {
9526          require ExtUtils::Manifest;
9527          my $cwd = CPAN::anycwd();
9528          $self->safe_chdir($where);
9529          ExtUtils::Manifest::mkmanifest();
9530          $self->safe_chdir($cwd);
9531      }
9532      my $fh = FileHandle->new($manifest)
9533          or Carp::croak("Couldn't open $manifest: $!");
9534      local($/) = "\n";
9535      my $bundle_filename = $what;
9536      $bundle_filename =~ s|Bundle.*/||;
9537      my $bundle_unixpath;
9538      while (<$fh>) {
9539          next if /^\s*\#/;
9540          my($file) = /(\S+)/;
9541          if ($file =~ m|\Q$what\E$|) {
9542              $bundle_unixpath = $file;
9543              # return File::Spec->catfile($where,$bundle_unixpath); # bad
9544              last;
9545          }
9546          # retry if she managed to have no Bundle directory
9547          $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
9548      }
9549      return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9550          if $bundle_unixpath;
9551      Carp::croak("Couldn't find a Bundle file in $where");
9552  }
9553  
9554  # needs to work quite differently from Module::inst_file because of
9555  # cpan_home/Bundle/ directory and the possibility that we have
9556  # shadowing effect. As it makes no sense to take the first in @INC for
9557  # Bundles, we parse them all for $VERSION and take the newest.
9558  
9559  #-> sub CPAN::Bundle::inst_file ;
9560  sub inst_file {
9561      my($self) = @_;
9562      my($inst_file);
9563      my(@me);
9564      @me = split /::/, $self->id;
9565      $me[-1] .= ".pm";
9566      my($incdir,$bestv);
9567      foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9568          my $bfile = File::Spec->catfile($incdir, @me);
9569          CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9570          next unless -f $bfile;
9571          my $foundv = MM->parse_version($bfile);
9572          if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9573              $self->{INST_FILE} = $bfile;
9574              $self->{INST_VERSION} = $bestv = $foundv;
9575          }
9576      }
9577      $self->{INST_FILE};
9578  }
9579  
9580  #-> sub CPAN::Bundle::inst_version ;
9581  sub inst_version {
9582      my($self) = @_;
9583      $self->inst_file; # finds INST_VERSION as side effect
9584      $self->{INST_VERSION};
9585  }
9586  
9587  #-> sub CPAN::Bundle::rematein ;
9588  sub rematein {
9589      my($self,$meth) = @_;
9590      $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9591      my($id) = $self->id;
9592      Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9593          unless $self->inst_file || $self->cpan_file;
9594      my($s,%fail);
9595      for $s ($self->contains) {
9596          my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9597              $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9598          if ($type eq 'CPAN::Distribution') {
9599              $CPAN::Frontend->mywarn(qq{
9600  The Bundle }.$self->id.qq{ contains
9601  explicitly a file '$s'.
9602  Going to $meth that.
9603  });
9604              $CPAN::Frontend->mysleep(5);
9605          }
9606          # possibly noisy action:
9607          $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9608          my $obj = $CPAN::META->instance($type,$s);
9609          $obj->{reqtype} = $self->{reqtype};
9610          $obj->$meth();
9611      }
9612  }
9613  
9614  # If a bundle contains another that contains an xs_file we have here,
9615  # we just don't bother I suppose
9616  #-> sub CPAN::Bundle::xs_file
9617  sub xs_file {
9618      return 0;
9619  }
9620  
9621  #-> sub CPAN::Bundle::force ;
9622  sub fforce   { shift->rematein('fforce',@_); }
9623  #-> sub CPAN::Bundle::force ;
9624  sub force   { shift->rematein('force',@_); }
9625  #-> sub CPAN::Bundle::notest ;
9626  sub notest  { shift->rematein('notest',@_); }
9627  #-> sub CPAN::Bundle::get ;
9628  sub get     { shift->rematein('get',@_); }
9629  #-> sub CPAN::Bundle::make ;
9630  sub make    { shift->rematein('make',@_); }
9631  #-> sub CPAN::Bundle::test ;
9632  sub test    {
9633      my $self = shift;
9634      # $self->{badtestcnt} ||= 0;
9635      $self->rematein('test',@_);
9636  }
9637  #-> sub CPAN::Bundle::install ;
9638  sub install {
9639    my $self = shift;
9640    $self->rematein('install',@_);
9641  }
9642  #-> sub CPAN::Bundle::clean ;
9643  sub clean   { shift->rematein('clean',@_); }
9644  
9645  #-> sub CPAN::Bundle::uptodate ;
9646  sub uptodate {
9647      my($self) = @_;
9648      return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9649      my $c;
9650      foreach $c ($self->contains) {
9651          my $obj = CPAN::Shell->expandany($c);
9652          return 0 unless $obj->uptodate;
9653      }
9654      return 1;
9655  }
9656  
9657  #-> sub CPAN::Bundle::readme ;
9658  sub readme  {
9659      my($self) = @_;
9660      my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9661  No File found for bundle } . $self->id . qq{\n}), return;
9662      $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9663      $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9664  }
9665  
9666  package CPAN::Module;
9667  use strict;
9668  
9669  # Accessors
9670  #-> sub CPAN::Module::userid
9671  sub userid {
9672      my $self = shift;
9673      my $ro = $self->ro;
9674      return unless $ro;
9675      return $ro->{userid} || $ro->{CPAN_USERID};
9676  }
9677  #-> sub CPAN::Module::description
9678  sub description {
9679      my $self = shift;
9680      my $ro = $self->ro or return "";
9681      $ro->{description}
9682  }
9683  
9684  #-> sub CPAN::Module::distribution
9685  sub distribution {
9686      my($self) = @_;
9687      CPAN::Shell->expand("Distribution",$self->cpan_file);
9688  }
9689  
9690  #-> sub CPAN::Module::undelay
9691  sub undelay {
9692      my $self = shift;
9693      delete $self->{later};
9694      if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9695          $dist->undelay;
9696      }
9697  }
9698  
9699  # mark as dirty/clean
9700  #-> sub CPAN::Module::color_cmd_tmps ;
9701  sub color_cmd_tmps {
9702      my($self) = shift;
9703      my($depth) = shift || 0;
9704      my($color) = shift || 0;
9705      my($ancestors) = shift || [];
9706      # a module needs to recurse to its cpan_file
9707  
9708      return if exists $self->{incommandcolor}
9709          && $color==1
9710          && $self->{incommandcolor}==$color;
9711      return if $color==0 && !$self->{incommandcolor};
9712      if ($color>=1) {
9713          if ( $self->uptodate ) {
9714              $self->{incommandcolor} = $color;
9715              return;
9716          } elsif (my $have_version = $self->available_version) {
9717              # maybe what we have is good enough
9718              if (@$ancestors) {
9719                  my $who_asked_for_me = $ancestors->[-1];
9720                  my $obj = CPAN::Shell->expandany($who_asked_for_me);
9721                  if (0) {
9722                  } elsif ($obj->isa("CPAN::Bundle")) {
9723                      # bundles cannot specify a minimum version
9724                      return;
9725                  } elsif ($obj->isa("CPAN::Distribution")) {
9726                      if (my $prereq_pm = $obj->prereq_pm) {
9727                          for my $k (keys %$prereq_pm) {
9728                              if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9729                                  if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9730                                      $self->{incommandcolor} = $color;
9731                                      return;
9732                                  }
9733                              }
9734                          }
9735                      }
9736                  }
9737              }
9738          }
9739      } else {
9740          $self->{incommandcolor} = $color; # set me before recursion,
9741                                            # so we can break it
9742      }
9743      if ($depth>=$CPAN::MAX_RECURSION) {
9744          die(CPAN::Exception::RecursiveDependency->new($ancestors));
9745      }
9746      # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9747  
9748      if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9749          $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9750      }
9751      # unreached code?
9752      # if ($color==0) {
9753      #    delete $self->{badtestcnt};
9754      # }
9755      $self->{incommandcolor} = $color;
9756  }
9757  
9758  #-> sub CPAN::Module::as_glimpse ;
9759  sub as_glimpse {
9760      my($self) = @_;
9761      my(@m);
9762      my $class = ref($self);
9763      $class =~ s/^CPAN:://;
9764      my $color_on = "";
9765      my $color_off = "";
9766      if (
9767          $CPAN::Shell::COLOR_REGISTERED
9768          &&
9769          $CPAN::META->has_inst("Term::ANSIColor")
9770          &&
9771          $self->description
9772         ) {
9773          $color_on = Term::ANSIColor::color("green");
9774          $color_off = Term::ANSIColor::color("reset");
9775      }
9776      my $uptodateness = " ";
9777      unless ($class eq "Bundle") {
9778          my $u = $self->uptodate;
9779          $uptodateness = $u ? "=" : "<" if defined $u;
9780      };
9781      my $id = do {
9782          my $d = $self->distribution;
9783          $d ? $d -> pretty_id : $self->cpan_userid;
9784      };
9785      push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9786                       $class,
9787                       $uptodateness,
9788                       $color_on,
9789                       $self->id,
9790                       $color_off,
9791                       $id,
9792                      );
9793      join "", @m;
9794  }
9795  
9796  #-> sub CPAN::Module::dslip_status
9797  sub dslip_status {
9798      my($self) = @_;
9799      my($stat);
9800      # development status
9801      @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9802                                                pre-alpha alpha beta released
9803                                                mature standard,;
9804      # support level
9805      @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9806                                                developer comp.lang.perl.*
9807                                                none abandoned,;
9808      # language
9809      @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9810      # interface
9811      @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9812                                                references+ties
9813                                                object-oriented pragma
9814                                                hybrid none,;
9815      # public licence
9816      @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
9817                                                GPL LGPL
9818                                                BSD Artistic Artistic_2
9819                                                open-source
9820                                                distribution_allowed
9821                                                restricted_distribution
9822                                                no_licence,;
9823      for my $x (qw(d s l i p)) {
9824          $stat->{$x}{' '} = 'unknown';
9825          $stat->{$x}{'?'} = 'unknown';
9826      }
9827      my $ro = $self->ro;
9828      return +{} unless $ro && $ro->{statd};
9829      return {
9830              D  => $ro->{statd},
9831              S  => $ro->{stats},
9832              L  => $ro->{statl},
9833              I  => $ro->{stati},
9834              P  => $ro->{statp},
9835              DV => $stat->{D}{$ro->{statd}},
9836              SV => $stat->{S}{$ro->{stats}},
9837              LV => $stat->{L}{$ro->{statl}},
9838              IV => $stat->{I}{$ro->{stati}},
9839              PV => $stat->{P}{$ro->{statp}},
9840             };
9841  }
9842  
9843  #-> sub CPAN::Module::as_string ;
9844  sub as_string {
9845      my($self) = @_;
9846      my(@m);
9847      CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9848      my $class = ref($self);
9849      $class =~ s/^CPAN:://;
9850      local($^W) = 0;
9851      push @m, $class, " id = $self->{ID}\n";
9852      my $sprintf = "    %-12s %s\n";
9853      push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9854          if $self->description;
9855      my $sprintf2 = "    %-12s %s (%s)\n";
9856      my($userid);
9857      $userid = $self->userid;
9858      if ( $userid ) {
9859          my $author;
9860          if ($author = CPAN::Shell->expand('Author',$userid)) {
9861              my $email = "";
9862              my $m; # old perls
9863              if ($m = $author->email) {
9864                  $email = " <$m>";
9865              }
9866              push @m, sprintf(
9867                               $sprintf2,
9868                               'CPAN_USERID',
9869                               $userid,
9870                               $author->fullname . $email
9871                              );
9872          }
9873      }
9874      push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9875          if $self->cpan_version;
9876      if (my $cpan_file = $self->cpan_file) {
9877          push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9878          if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9879              my $upload_date = $dist->upload_date;
9880              if ($upload_date) {
9881                  push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9882              }
9883          }
9884      }
9885      my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9886      my $dslip = $self->dslip_status;
9887      push @m, sprintf(
9888                       $sprintf3,
9889                       'DSLIP_STATUS',
9890                       @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9891                      ) if $dslip->{D};
9892      my $local_file = $self->inst_file;
9893      unless ($self->{MANPAGE}) {
9894          my $manpage;
9895          if ($local_file) {
9896              $manpage = $self->manpage_headline($local_file);
9897          } else {
9898              # If we have already untarred it, we should look there
9899              my $dist = $CPAN::META->instance('CPAN::Distribution',
9900                                               $self->cpan_file);
9901              # warn "dist[$dist]";
9902              # mff=manifest file; mfh=manifest handle
9903              my($mff,$mfh);
9904              if (
9905                  $dist->{build_dir}
9906                  and
9907                  (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9908                  and
9909                  $mfh = FileHandle->new($mff)
9910                 ) {
9911                  CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9912                  my $lfre = $self->id; # local file RE
9913                  $lfre =~ s/::/./g;
9914                  $lfre .= "\\.pm\$";
9915                  my($lfl); # local file file
9916                  local $/ = "\n";
9917                  my(@mflines) = <$mfh>;
9918                  for (@mflines) {
9919                      s/^\s+//;
9920                      s/\s.*//s;
9921                  }
9922                  while (length($lfre)>5 and !$lfl) {
9923                      ($lfl) = grep /$lfre/, @mflines;
9924                      CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9925                      $lfre =~ s/.+?\.//;
9926                  }
9927                  $lfl =~ s/\s.*//; # remove comments
9928                  $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9929                  my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9930                  # warn "lfl_abs[$lfl_abs]";
9931                  if (-f $lfl_abs) {
9932                      $manpage = $self->manpage_headline($lfl_abs);
9933                  }
9934              }
9935          }
9936          $self->{MANPAGE} = $manpage if $manpage;
9937      }
9938      my($item);
9939      for $item (qw/MANPAGE/) {
9940          push @m, sprintf($sprintf, $item, $self->{$item})
9941              if exists $self->{$item};
9942      }
9943      for $item (qw/CONTAINS/) {
9944          push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9945              if exists $self->{$item} && @{$self->{$item}};
9946      }
9947      push @m, sprintf($sprintf, 'INST_FILE',
9948                       $local_file || "(not installed)");
9949      push @m, sprintf($sprintf, 'INST_VERSION',
9950                       $self->inst_version) if $local_file;
9951      join "", @m, "\n";
9952  }
9953  
9954  #-> sub CPAN::Module::manpage_headline
9955  sub manpage_headline {
9956      my($self,$local_file) = @_;
9957      my(@local_file) = $local_file;
9958      $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9959      push @local_file, $local_file;
9960      my(@result,$locf);
9961      for $locf (@local_file) {
9962          next unless -f $locf;
9963          my $fh = FileHandle->new($locf)
9964              or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9965          my $inpod = 0;
9966          local $/ = "\n";
9967          while (<$fh>) {
9968              $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9969                  m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9970              next unless $inpod;
9971              next if /^=/;
9972              next if /^\s+$/;
9973              chomp;
9974              push @result, $_;
9975          }
9976          close $fh;
9977          last if @result;
9978      }
9979      for (@result) {
9980          s/^\s+//;
9981          s/\s+$//;
9982      }
9983      join " ", @result;
9984  }
9985  
9986  #-> sub CPAN::Module::cpan_file ;
9987  # Note: also inherited by CPAN::Bundle
9988  sub cpan_file {
9989      my $self = shift;
9990      # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9991      unless ($self->ro) {
9992          CPAN::Index->reload;
9993      }
9994      my $ro = $self->ro;
9995      if ($ro && defined $ro->{CPAN_FILE}) {
9996          return $ro->{CPAN_FILE};
9997      } else {
9998          my $userid = $self->userid;
9999          if ( $userid ) {
10000              if ($CPAN::META->exists("CPAN::Author",$userid)) {
10001                  my $author = $CPAN::META->instance("CPAN::Author",
10002                                                     $userid);
10003                  my $fullname = $author->fullname;
10004                  my $email = $author->email;
10005                  unless (defined $fullname && defined $email) {
10006                      return sprintf("Contact Author %s",
10007                                     $userid,
10008                                    );
10009                  }
10010                  return "Contact Author $fullname <$email>";
10011              } else {
10012                  return "Contact Author $userid (Email address not available)";
10013              }
10014          } else {
10015              return "N/A";
10016          }
10017      }
10018  }
10019  
10020  #-> sub CPAN::Module::cpan_version ;
10021  sub cpan_version {
10022      my $self = shift;
10023  
10024      my $ro = $self->ro;
10025      unless ($ro) {
10026          # Can happen with modules that are not on CPAN
10027          $ro = {};
10028      }
10029      $ro->{CPAN_VERSION} = 'undef'
10030          unless defined $ro->{CPAN_VERSION};
10031      $ro->{CPAN_VERSION};
10032  }
10033  
10034  #-> sub CPAN::Module::force ;
10035  sub force {
10036      my($self) = @_;
10037      $self->{force_update} = 1;
10038  }
10039  
10040  #-> sub CPAN::Module::fforce ;
10041  sub fforce {
10042      my($self) = @_;
10043      $self->{force_update} = 2;
10044  }
10045  
10046  #-> sub CPAN::Module::notest ;
10047  sub notest {
10048      my($self) = @_;
10049      # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10050      $self->{notest}++;
10051  }
10052  
10053  #-> sub CPAN::Module::rematein ;
10054  sub rematein {
10055      my($self,$meth) = @_;
10056      $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10057                                       $meth,
10058                                       $self->id));
10059      my $cpan_file = $self->cpan_file;
10060      if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10061          $CPAN::Frontend->mywarn(sprintf qq{
10062    The module %s isn\'t available on CPAN.
10063  
10064    Either the module has not yet been uploaded to CPAN, or it is
10065    temporary unavailable. Please contact the author to find out
10066    more about the status. Try 'i %s'.
10067  },
10068                                  $self->id,
10069                                  $self->id,
10070                                 );
10071          return;
10072      }
10073      my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10074      $pack->called_for($self->id);
10075      if (exists $self->{force_update}) {
10076          if ($self->{force_update} == 2) {
10077              $pack->fforce($meth);
10078          } else {
10079              $pack->force($meth);
10080          }
10081      }
10082      $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10083  
10084      $pack->{reqtype} ||= "";
10085      CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10086                  "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10087          if ($pack->{reqtype}) {
10088              if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10089                  $pack->{reqtype} = $self->{reqtype};
10090                  if (
10091                      exists $pack->{install}
10092                      &&
10093                      (
10094                       UNIVERSAL::can($pack->{install},"failed") ?
10095                       $pack->{install}->failed :
10096                       $pack->{install} =~ /^NO/
10097                      )
10098                     ) {
10099                      delete $pack->{install};
10100                      $CPAN::Frontend->mywarn
10101                          ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10102                  }
10103              }
10104          } else {
10105              $pack->{reqtype} = $self->{reqtype};
10106          }
10107  
10108      my $success = eval {
10109          $pack->$meth();
10110      };
10111      my $err = $@;
10112      $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10113      $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10114      delete $self->{force_update};
10115      delete $self->{notest};
10116      if ($err) {
10117          die $err;
10118      }
10119      return $success;
10120  }
10121  
10122  #-> sub CPAN::Module::perldoc ;
10123  sub perldoc { shift->rematein('perldoc') }
10124  #-> sub CPAN::Module::readme ;
10125  sub readme  { shift->rematein('readme') }
10126  #-> sub CPAN::Module::look ;
10127  sub look    { shift->rematein('look') }
10128  #-> sub CPAN::Module::cvs_import ;
10129  sub cvs_import { shift->rematein('cvs_import') }
10130  #-> sub CPAN::Module::get ;
10131  sub get     { shift->rematein('get',@_) }
10132  #-> sub CPAN::Module::make ;
10133  sub make    { shift->rematein('make') }
10134  #-> sub CPAN::Module::test ;
10135  sub test   {
10136      my $self = shift;
10137      # $self->{badtestcnt} ||= 0;
10138      $self->rematein('test',@_);
10139  }
10140  
10141  #-> sub CPAN::Module::uptodate ;
10142  sub uptodate {
10143      my ($self) = @_;
10144      local ($_);
10145      my $inst = $self->inst_version or return undef;
10146      my $cpan = $self->cpan_version;
10147      local ($^W) = 0;
10148      CPAN::Version->vgt($cpan,$inst) and return 0;
10149      CPAN->debug(join("",
10150                       "returning uptodate. inst_file[",
10151                       $self->inst_file,
10152                       "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10153      return 1;
10154  }
10155  
10156  #-> sub CPAN::Module::install ;
10157  sub install {
10158      my($self) = @_;
10159      my($doit) = 0;
10160      if ($self->uptodate
10161          &&
10162          not exists $self->{force_update}
10163         ) {
10164          $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10165                                           $self->id,
10166                                           $self->inst_version,
10167                                          ));
10168      } else {
10169          $doit = 1;
10170      }
10171      my $ro = $self->ro;
10172      if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10173          $CPAN::Frontend->mywarn(qq{
10174  \n\n\n     ***WARNING***
10175       The module $self->{ID} has no active maintainer.\n\n\n
10176  });
10177          $CPAN::Frontend->mysleep(5);
10178      }
10179      $self->rematein('install') if $doit;
10180  }
10181  #-> sub CPAN::Module::clean ;
10182  sub clean  { shift->rematein('clean') }
10183  
10184  #-> sub CPAN::Module::inst_file ;
10185  sub inst_file {
10186      my($self) = @_;
10187      $self->_file_in_path([@INC]);
10188  }
10189  
10190  #-> sub CPAN::Module::available_file ;
10191  sub available_file {
10192      my($self) = @_;
10193      my $sep = $Config::Config{path_sep};
10194      my $perllib = $ENV{PERL5LIB};
10195      $perllib = $ENV{PERLLIB} unless defined $perllib;
10196      my @perllib = split(/$sep/,$perllib) if defined $perllib;
10197      $self->_file_in_path([@perllib,@INC]);
10198  }
10199  
10200  #-> sub CPAN::Module::file_in_path ;
10201  sub _file_in_path {
10202      my($self,$path) = @_;
10203      my($dir,@packpath);
10204      @packpath = split /::/, $self->{ID};
10205      $packpath[-1] .= ".pm";
10206      if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10207          unshift @packpath, "Term", "ReadLine"; # historical reasons
10208      }
10209      foreach $dir (@$path) {
10210          my $pmfile = File::Spec->catfile($dir,@packpath);
10211          if (-f $pmfile) {
10212              return $pmfile;
10213          }
10214      }
10215      return;
10216  }
10217  
10218  #-> sub CPAN::Module::xs_file ;
10219  sub xs_file {
10220      my($self) = @_;
10221      my($dir,@packpath);
10222      @packpath = split /::/, $self->{ID};
10223      push @packpath, $packpath[-1];
10224      $packpath[-1] .= "." . $Config::Config{'dlext'};
10225      foreach $dir (@INC) {
10226          my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10227          if (-f $xsfile) {
10228              return $xsfile;
10229          }
10230      }
10231      return;
10232  }
10233  
10234  #-> sub CPAN::Module::inst_version ;
10235  sub inst_version {
10236      my($self) = @_;
10237      my $parsefile = $self->inst_file or return;
10238      my $have = $self->parse_version($parsefile);
10239      $have;
10240  }
10241  
10242  #-> sub CPAN::Module::inst_version ;
10243  sub available_version {
10244      my($self) = @_;
10245      my $parsefile = $self->available_file or return;
10246      my $have = $self->parse_version($parsefile);
10247      $have;
10248  }
10249  
10250  #-> sub CPAN::Module::parse_version ;
10251  sub parse_version {
10252      my($self,$parsefile) = @_;
10253      my $have = MM->parse_version($parsefile);
10254      $have = "undef" unless defined $have && length $have;
10255      $have =~ s/^ //; # since the %vd hack these two lines here are needed
10256      $have =~ s/ $//; # trailing whitespace happens all the time
10257  
10258      $have = CPAN::Version->readable($have);
10259  
10260      $have =~ s/\s*//g; # stringify to float around floating point issues
10261      $have; # no stringify needed, \s* above matches always
10262  }
10263  
10264  #-> sub CPAN::Module::reports
10265  sub reports {
10266      my($self) = @_;
10267      $self->distribution->reports;
10268  }
10269  
10270  package CPAN;
10271  use strict;
10272  
10273  1;
10274  
10275  
10276  __END__
10277  
10278  =head1 NAME
10279  
10280  CPAN - query, download and build perl modules from CPAN sites
10281  
10282  =head1 SYNOPSIS
10283  
10284  Interactive mode:
10285  
10286    perl -MCPAN -e shell
10287  
10288  --or--
10289  
10290    cpan
10291  
10292  Basic commands:
10293  
10294    # Modules:
10295  
10296    cpan> install Acme::Meta                       # in the shell
10297  
10298    CPAN::Shell->install("Acme::Meta");            # in perl
10299  
10300    # Distributions:
10301  
10302    cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10303  
10304    CPAN::Shell->
10305      install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10306  
10307    # module objects:
10308  
10309    $mo = CPAN::Shell->expandany($mod);
10310    $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10311  
10312    # distribution objects:
10313  
10314    $do = CPAN::Shell->expand("Module",$mod)->distribution;
10315    $do = CPAN::Shell->expandany($distro);         # same thing
10316    $do = CPAN::Shell->expand("Distribution",
10317                              $distro);            # same thing
10318  
10319  =head1 DESCRIPTION
10320  
10321  The CPAN module automates or at least simplifies the make and install
10322  of perl modules and extensions. It includes some primitive searching
10323  capabilities and knows how to use Net::FTP or LWP or some external
10324  download clients to fetch the distributions from the net.
10325  
10326  These are fetched from one or more of the mirrored CPAN (Comprehensive
10327  Perl Archive Network) sites and unpacked in a dedicated directory.
10328  
10329  The CPAN module also supports the concept of named and versioned
10330  I<bundles> of modules. Bundles simplify the handling of sets of
10331  related modules. See Bundles below.
10332  
10333  The package contains a session manager and a cache manager. The
10334  session manager keeps track of what has been fetched, built and
10335  installed in the current session. The cache manager keeps track of the
10336  disk space occupied by the make processes and deletes excess space
10337  according to a simple FIFO mechanism.
10338  
10339  All methods provided are accessible in a programmer style and in an
10340  interactive shell style.
10341  
10342  =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10343  
10344  The interactive mode is entered by running
10345  
10346      perl -MCPAN -e shell
10347  
10348  or
10349  
10350      cpan
10351  
10352  which puts you into a readline interface. If C<Term::ReadKey> and
10353  either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10354  it supports both history and command completion.
10355  
10356  Once you are on the command line, type C<h> to get a one page help
10357  screen and the rest should be self-explanatory.
10358  
10359  The function call C<shell> takes two optional arguments, one is the
10360  prompt, the second is the default initial command line (the latter
10361  only works if a real ReadLine interface module is installed).
10362  
10363  The most common uses of the interactive modes are
10364  
10365  =over 2
10366  
10367  =item Searching for authors, bundles, distribution files and modules
10368  
10369  There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10370  for each of the four categories and another, C<i> for any of the
10371  mentioned four. Each of the four entities is implemented as a class
10372  with slightly differing methods for displaying an object.
10373  
10374  Arguments you pass to these commands are either strings exactly matching
10375  the identification string of an object or regular expressions that are
10376  then matched case-insensitively against various attributes of the
10377  objects. The parser recognizes a regular expression only if you
10378  enclose it between two slashes.
10379  
10380  The principle is that the number of found objects influences how an
10381  item is displayed. If the search finds one item, the result is
10382  displayed with the rather verbose method C<as_string>, but if we find
10383  more than one, we display each object with the terse method
10384  C<as_glimpse>.
10385  
10386  =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10387  
10388  These commands take any number of arguments and investigate what is
10389  necessary to perform the action. If the argument is a distribution
10390  file name (recognized by embedded slashes), it is processed. If it is
10391  a module, CPAN determines the distribution file in which this module
10392  is included and processes that, following any dependencies named in
10393  the module's META.yml or Makefile.PL (this behavior is controlled by
10394  the configuration parameter C<prerequisites_policy>.)
10395  
10396  C<get> downloads a distribution file and untars or unzips it, C<make>
10397  builds it, C<test> runs the test suite, and C<install> installs it.
10398  
10399  Any C<make> or C<test> are run unconditionally. An
10400  
10401    install <distribution_file>
10402  
10403  also is run unconditionally. But for
10404  
10405    install <module>
10406  
10407  CPAN checks if an install is actually needed for it and prints
10408  I<module up to date> in the case that the distribution file containing
10409  the module doesn't need to be updated.
10410  
10411  CPAN also keeps track of what it has done within the current session
10412  and doesn't try to build a package a second time regardless if it
10413  succeeded or not. It does not repeat a test run if the test
10414  has been run successfully before. Same for install runs.
10415  
10416  The C<force> pragma may precede another command (currently: C<get>,
10417  C<make>, C<test>, or C<install>) and executes the command from scratch
10418  and tries to continue in case of some errors. See the section below on
10419  the C<force> and the C<fforce> pragma.
10420  
10421  The C<notest> pragma may be used to skip the test part in the build
10422  process.
10423  
10424  Example:
10425  
10426      cpan> notest install Tk
10427  
10428  A C<clean> command results in a
10429  
10430    make clean
10431  
10432  being executed within the distribution file's working directory.
10433  
10434  =item C<readme>, C<perldoc>, C<look> module or distribution
10435  
10436  C<readme> displays the README file of the associated distribution.
10437  C<Look> gets and untars (if not yet done) the distribution file,
10438  changes to the appropriate directory and opens a subshell process in
10439  that directory. C<perldoc> displays the pod documentation of the
10440  module in html or plain text format.
10441  
10442  =item C<ls> author
10443  
10444  =item C<ls> globbing_expression
10445  
10446  The first form lists all distribution files in and below an author's
10447  CPAN directory as they are stored in the CHECKUMS files distributed on
10448  CPAN. The listing goes recursive into all subdirectories.
10449  
10450  The second form allows to limit or expand the output with shell
10451  globbing as in the following examples:
10452  
10453        ls JV/make*
10454        ls GSAR/*make*
10455        ls */*make*
10456  
10457  The last example is very slow and outputs extra progress indicators
10458  that break the alignment of the result.
10459  
10460  Note that globbing only lists directories explicitly asked for, for
10461  example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10462  regarded as a bug and may be changed in future versions.
10463  
10464  =item C<failed>
10465  
10466  The C<failed> command reports all distributions that failed on one of
10467  C<make>, C<test> or C<install> for some reason in the currently
10468  running shell session.
10469  
10470  =item Persistence between sessions
10471  
10472  If the C<YAML> or the C<YAML::Syck> module is installed a record of
10473  the internal state of all modules is written to disk after each step.
10474  The files contain a signature of the currently running perl version
10475  for later perusal.
10476  
10477  If the configurations variable C<build_dir_reuse> is set to a true
10478  value, then CPAN.pm reads the collected YAML files. If the stored
10479  signature matches the currently running perl the stored state is
10480  loaded into memory such that effectively persistence between sessions
10481  is established.
10482  
10483  =item The C<force> and the C<fforce> pragma
10484  
10485  To speed things up in complex installation scenarios, CPAN.pm keeps
10486  track of what it has already done and refuses to do some things a
10487  second time. A C<get>, a C<make>, and an C<install> are not repeated.
10488  A C<test> is only repeated if the previous test was unsuccessful. The
10489  diagnostic message when CPAN.pm refuses to do something a second time
10490  is one of I<Has already been >C<unwrapped|made|tested successfully> or
10491  something similar. Another situation where CPAN refuses to act is an
10492  C<install> if the according C<test> was not successful.
10493  
10494  In all these cases, the user can override the goatish behaviour by
10495  prepending the command with the word force, for example:
10496  
10497    cpan> force get Foo
10498    cpan> force make AUTHOR/Bar-3.14.tar.gz
10499    cpan> force test Baz
10500    cpan> force install Acme::Meta
10501  
10502  Each I<forced> command is executed with the according part of its
10503  memory erased.
10504  
10505  The C<fforce> pragma is a variant that emulates a C<force get> which
10506  erases the entire memory followed by the action specified, effectively
10507  restarting the whole get/make/test/install procedure from scratch.
10508  
10509  =item Lockfile
10510  
10511  Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10512  Batch jobs can run without a lockfile and do not disturb each other.
10513  
10514  The shell offers to run in I<degraded mode> when another process is
10515  holding the lockfile. This is an experimental feature that is not yet
10516  tested very well. This second shell then does not write the history
10517  file, does not use the metadata file and has a different prompt.
10518  
10519  =item Signals
10520  
10521  CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10522  in the cpan-shell it is intended that you can press C<^C> anytime and
10523  return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10524  to clean up and leave the shell loop. You can emulate the effect of a
10525  SIGTERM by sending two consecutive SIGINTs, which usually means by
10526  pressing C<^C> twice.
10527  
10528  CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
10529  SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10530  Build.PL> subprocess.
10531  
10532  =back
10533  
10534  =head2 CPAN::Shell
10535  
10536  The commands that are available in the shell interface are methods in
10537  the package CPAN::Shell. If you enter the shell command, all your
10538  input is split by the Text::ParseWords::shellwords() routine which
10539  acts like most shells do. The first word is being interpreted as the
10540  method to be called and the rest of the words are treated as arguments
10541  to this method. Continuation lines are supported if a line ends with a
10542  literal backslash.
10543  
10544  =head2 autobundle
10545  
10546  C<autobundle> writes a bundle file into the
10547  C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10548  a list of all modules that are both available from CPAN and currently
10549  installed within @INC. The name of the bundle file is based on the
10550  current date and a counter.
10551  
10552  =head2 hosts
10553  
10554  Note: this feature is still in alpha state and may change in future
10555  versions of CPAN.pm
10556  
10557  This commands provides a statistical overview over recent download
10558  activities. The data for this is collected in the YAML file
10559  C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10560  configured or YAML not installed, then no stats are provided.
10561  
10562  =head2 mkmyconfig
10563  
10564  mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10565  directory so that you can save your own preferences instead of the
10566  system wide ones.
10567  
10568  =head2 recent ***EXPERIMENTAL COMMAND***
10569  
10570  The C<recent> command downloads a list of recent uploads to CPAN and
10571  displays them I<slowly>. While the command is running $SIG{INT} is
10572  defined to mean that the loop shall be left after having displayed the
10573  current item.
10574  
10575  B<Note>: This command requires XML::LibXML installed.
10576  
10577  B<Note>: This whole command currently is a bit klunky and will
10578  probably change in future versions of CPAN.pm but the general
10579  approach will likely stay.
10580  
10581  B<Note>: See also L<smoke>
10582  
10583  =head2 recompile
10584  
10585  recompile() is a very special command in that it takes no argument and
10586  runs the make/test/install cycle with brute force over all installed
10587  dynamically loadable extensions (aka XS modules) with 'force' in
10588  effect. The primary purpose of this command is to finish a network
10589  installation. Imagine, you have a common source tree for two different
10590  architectures. You decide to do a completely independent fresh
10591  installation. You start on one architecture with the help of a Bundle
10592  file produced earlier. CPAN installs the whole Bundle for you, but
10593  when you try to repeat the job on the second architecture, CPAN
10594  responds with a C<"Foo up to date"> message for all modules. So you
10595  invoke CPAN's recompile on the second architecture and you're done.
10596  
10597  Another popular use for C<recompile> is to act as a rescue in case your
10598  perl breaks binary compatibility. If one of the modules that CPAN uses
10599  is in turn depending on binary compatibility (so you cannot run CPAN
10600  commands), then you should try the CPAN::Nox module for recovery.
10601  
10602  =head2 report Bundle|Distribution|Module
10603  
10604  The C<report> command temporarily turns on the C<test_report> config
10605  variable, then runs the C<force test> command with the given
10606  arguments. The C<force> pragma is used to re-run the tests and repeat
10607  every step that might have failed before.
10608  
10609  =head2 smoke ***EXPERIMENTAL COMMAND***
10610  
10611  B<*** WARNING: this command downloads and executes software from CPAN to
10612  your computer of completely unknown status. You should never do
10613  this with your normal account and better have a dedicated well
10614  separated and secured machine to do this. ***>
10615  
10616  The C<smoke> command takes the list of recent uploads to CPAN as
10617  provided by the C<recent> command and tests them all. While the
10618  command is running $SIG{INT} is defined to mean that the current item
10619  shall be skipped.
10620  
10621  B<Note>: This whole command currently is a bit klunky and will
10622  probably change in future versions of CPAN.pm but the general
10623  approach will likely stay.
10624  
10625  B<Note>: See also L<recent>
10626  
10627  =head2 upgrade [Module|/Regex/]...
10628  
10629  The C<upgrade> command first runs an C<r> command with the given
10630  arguments and then installs the newest versions of all modules that
10631  were listed by that.
10632  
10633  =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10634  
10635  Although it may be considered internal, the class hierarchy does matter
10636  for both users and programmer. CPAN.pm deals with above mentioned four
10637  classes, and all those classes share a set of methods. A classical
10638  single polymorphism is in effect. A metaclass object registers all
10639  objects of all kinds and indexes them with a string. The strings
10640  referencing objects have a separated namespace (well, not completely
10641  separated):
10642  
10643           Namespace                         Class
10644  
10645     words containing a "/" (slash)      Distribution
10646      words starting with Bundle::          Bundle
10647            everything else            Module or Author
10648  
10649  Modules know their associated Distribution objects. They always refer
10650  to the most recent official release. Developers may mark their releases
10651  as unstable development versions (by inserting an underbar into the
10652  module version number which will also be reflected in the distribution
10653  name when you run 'make dist'), so the really hottest and newest
10654  distribution is not always the default.  If a module Foo circulates
10655  on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10656  way to install version 1.23 by saying
10657  
10658      install Foo
10659  
10660  This would install the complete distribution file (say
10661  BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10662  like to install version 1.23_90, you need to know where the
10663  distribution file resides on CPAN relative to the authors/id/
10664  directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10665  so you would have to say
10666  
10667      install BAR/Foo-1.23_90.tar.gz
10668  
10669  The first example will be driven by an object of the class
10670  CPAN::Module, the second by an object of class CPAN::Distribution.
10671  
10672  =head2 Integrating local directories
10673  
10674  Note: this feature is still in alpha state and may change in future
10675  versions of CPAN.pm
10676  
10677  Distribution objects are normally distributions from the CPAN, but
10678  there is a slightly degenerate case for Distribution objects, too, of
10679  projects held on the local disk. These distribution objects have the
10680  same name as the local directory and end with a dot. A dot by itself
10681  is also allowed for the current directory at the time CPAN.pm was
10682  used. All actions such as C<make>, C<test>, and C<install> are applied
10683  directly to that directory. This gives the command C<cpan .> an
10684  interesting touch: while the normal mantra of installing a CPAN module
10685  without CPAN.pm is one of
10686  
10687      perl Makefile.PL                 perl Build.PL
10688             ( go and get prerequisites )
10689      make                             ./Build
10690      make test                        ./Build test
10691      make install                     ./Build install
10692  
10693  the command C<cpan .> does all of this at once. It figures out which
10694  of the two mantras is appropriate, fetches and installs all
10695  prerequisites, cares for them recursively and finally finishes the
10696  installation of the module in the current directory, be it a CPAN
10697  module or not.
10698  
10699  The typical usage case is for private modules or working copies of
10700  projects from remote repositories on the local disk.
10701  
10702  =head1 CONFIGURATION
10703  
10704  When the CPAN module is used for the first time, a configuration
10705  dialog tries to determine a couple of site specific options. The
10706  result of the dialog is stored in a hash reference C< $CPAN::Config >
10707  in a file CPAN/Config.pm.
10708  
10709  The default values defined in the CPAN/Config.pm file can be
10710  overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10711  best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10712  added to the search path of the CPAN module before the use() or
10713  require() statements. The mkmyconfig command writes this file for you.
10714  
10715  The C<o conf> command has various bells and whistles:
10716  
10717  =over
10718  
10719  =item completion support
10720  
10721  If you have a ReadLine module installed, you can hit TAB at any point
10722  of the commandline and C<o conf> will offer you completion for the
10723  built-in subcommands and/or config variable names.
10724  
10725  =item displaying some help: o conf help
10726  
10727  Displays a short help
10728  
10729  =item displaying current values: o conf [KEY]
10730  
10731  Displays the current value(s) for this config variable. Without KEY
10732  displays all subcommands and config variables.
10733  
10734  Example:
10735  
10736    o conf shell
10737  
10738  If KEY starts and ends with a slash the string in between is
10739  interpreted as a regular expression and only keys matching this regex
10740  are displayed
10741  
10742  Example:
10743  
10744    o conf /color/
10745  
10746  =item changing of scalar values: o conf KEY VALUE
10747  
10748  Sets the config variable KEY to VALUE. The empty string can be
10749  specified as usual in shells, with C<''> or C<"">
10750  
10751  Example:
10752  
10753    o conf wget /usr/bin/wget
10754  
10755  =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10756  
10757  If a config variable name ends with C<list>, it is a list. C<o conf
10758  KEY shift> removes the first element of the list, C<o conf KEY pop>
10759  removes the last element of the list. C<o conf KEYS unshift LIST>
10760  prepends a list of values to the list, C<o conf KEYS push LIST>
10761  appends a list of valued to the list.
10762  
10763  Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10764  splice command.
10765  
10766  Finally, any other list of arguments is taken as a new list value for
10767  the KEY variable discarding the previous value.
10768  
10769  Examples:
10770  
10771    o conf urllist unshift http://cpan.dev.local/CPAN
10772    o conf urllist splice 3 1
10773    o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10774  
10775  =item reverting to saved: o conf defaults
10776  
10777  Reverts all config variables to the state in the saved config file.
10778  
10779  =item saving the config: o conf commit
10780  
10781  Saves all config variables to the current config file (CPAN/Config.pm
10782  or CPAN/MyConfig.pm that was loaded at start).
10783  
10784  =back
10785  
10786  The configuration dialog can be started any time later again by
10787  issuing the command C< o conf init > in the CPAN shell. A subset of
10788  the configuration dialog can be run by issuing C<o conf init WORD>
10789  where WORD is any valid config variable or a regular expression.
10790  
10791  =head2 Config Variables
10792  
10793  Currently the following keys in the hash reference $CPAN::Config are
10794  defined:
10795  
10796    applypatch         path to external prg
10797    auto_commit        commit all changes to config variables to disk
10798    build_cache        size of cache for directories to build modules
10799    build_dir          locally accessible directory to build modules
10800    build_dir_reuse    boolean if distros in build_dir are persistent
10801    build_requires_install_policy
10802                       to install or not to install when a module is
10803                       only needed for building. yes|no|ask/yes|ask/no
10804    bzip2              path to external prg
10805    cache_metadata     use serializer to cache metadata
10806    commands_quote     prefered character to use for quoting external
10807                       commands when running them. Defaults to double
10808                       quote on Windows, single tick everywhere else;
10809                       can be set to space to disable quoting
10810    check_sigs         if signatures should be verified
10811    colorize_debug     Term::ANSIColor attributes for debugging output
10812    colorize_output    boolean if Term::ANSIColor should colorize output
10813    colorize_print     Term::ANSIColor attributes for normal output
10814    colorize_warn      Term::ANSIColor attributes for warnings
10815    commandnumber_in_prompt
10816                       boolean if you want to see current command number
10817    cpan_home          local directory reserved for this package
10818    curl               path to external prg
10819    dontload_hash      DEPRECATED
10820    dontload_list      arrayref: modules in the list will not be
10821                       loaded by the CPAN::has_inst() routine
10822    ftp                path to external prg
10823    ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10824    ftp_proxy          proxy host for ftp requests
10825    getcwd             see below
10826    gpg                path to external prg
10827    gzip               location of external program gzip
10828    histfile           file to maintain history between sessions
10829    histsize           maximum number of lines to keep in histfile
10830    http_proxy         proxy host for http requests
10831    inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10832                       after this many seconds inactivity. Set to 0 to
10833                       never break.
10834    index_expire       after this many days refetch index files
10835    inhibit_startup_message
10836                       if true, does not print the startup message
10837    keep_source_where  directory in which to keep the source (if we do)
10838    load_module_verbosity
10839                       report loading of optional modules used by CPAN.pm
10840    lynx               path to external prg
10841    make               location of external make program
10842    make_arg           arguments that should always be passed to 'make'
10843    make_install_make_command
10844                       the make command for running 'make install', for
10845                       example 'sudo make'
10846    make_install_arg   same as make_arg for 'make install'
10847    makepl_arg         arguments passed to 'perl Makefile.PL'
10848    mbuild_arg         arguments passed to './Build'
10849    mbuild_install_arg arguments passed to './Build install'
10850    mbuild_install_build_command
10851                       command to use instead of './Build' when we are
10852                       in the install stage, for example 'sudo ./Build'
10853    mbuildpl_arg       arguments passed to 'perl Build.PL'
10854    ncftp              path to external prg
10855    ncftpget           path to external prg
10856    no_proxy           don't proxy to these hosts/domains (comma separated list)
10857    pager              location of external program more (or any pager)
10858    password           your password if you CPAN server wants one
10859    patch              path to external prg
10860    prefer_installer   legal values are MB and EUMM: if a module comes
10861                       with both a Makefile.PL and a Build.PL, use the
10862                       former (EUMM) or the latter (MB); if the module
10863                       comes with only one of the two, that one will be
10864                       used in any case
10865    prerequisites_policy
10866                       what to do if you are missing module prerequisites
10867                       ('follow' automatically, 'ask' me, or 'ignore')
10868    prefs_dir          local directory to store per-distro build options
10869    proxy_user         username for accessing an authenticating proxy
10870    proxy_pass         password for accessing an authenticating proxy
10871    randomize_urllist  add some randomness to the sequence of the urllist
10872    scan_cache         controls scanning of cache ('atstart' or 'never')
10873    shell              your favorite shell
10874    show_unparsable_versions
10875                       boolean if r command tells which modules are versionless
10876    show_upload_date   boolean if commands should try to determine upload date
10877    show_zero_versions boolean if r command tells for which modules $version==0
10878    tar                location of external program tar
10879    tar_verbosity      verbosity level for the tar command
10880    term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
10881                       (and nonsense for characters outside latin range)
10882    term_ornaments     boolean to turn ReadLine ornamenting on/off
10883    test_report        email test reports (if CPAN::Reporter is installed)
10884    unzip              location of external program unzip
10885    urllist            arrayref to nearby CPAN sites (or equivalent locations)
10886    use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10887    username           your username if you CPAN server wants one
10888    wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10889    wget               path to external prg
10890    yaml_load_code     enable YAML code deserialisation
10891    yaml_module        which module to use to read/write YAML files
10892  
10893  You can set and query each of these options interactively in the cpan
10894  shell with the C<o conf> or the C<o conf init> command as specified below.
10895  
10896  =over 2
10897  
10898  =item C<o conf E<lt>scalar optionE<gt>>
10899  
10900  prints the current value of the I<scalar option>
10901  
10902  =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10903  
10904  Sets the value of the I<scalar option> to I<value>
10905  
10906  =item C<o conf E<lt>list optionE<gt>>
10907  
10908  prints the current value of the I<list option> in MakeMaker's
10909  neatvalue format.
10910  
10911  =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10912  
10913  shifts or pops the array in the I<list option> variable
10914  
10915  =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10916  
10917  works like the corresponding perl commands.
10918  
10919  =item interactive editing: o conf init [MATCH|LIST]
10920  
10921  Runs an interactive configuration dialog for matching variables.
10922  Without argument runs the dialog over all supported config variables.
10923  To specify a MATCH the argument must be enclosed by slashes.
10924  
10925  Examples:
10926  
10927    o conf init ftp_passive ftp_proxy
10928    o conf init /color/
10929  
10930  Note: this method of setting config variables often provides more
10931  explanation about the functioning of a variable than the manpage.
10932  
10933  =back
10934  
10935  =head2 CPAN::anycwd($path): Note on config variable getcwd
10936  
10937  CPAN.pm changes the current working directory often and needs to
10938  determine its own current working directory. Per default it uses
10939  Cwd::cwd but if this doesn't work on your system for some reason,
10940  alternatives can be configured according to the following table:
10941  
10942  =over 4
10943  
10944  =item cwd
10945  
10946  Calls Cwd::cwd
10947  
10948  =item getcwd
10949  
10950  Calls Cwd::getcwd
10951  
10952  =item fastcwd
10953  
10954  Calls Cwd::fastcwd
10955  
10956  =item backtickcwd
10957  
10958  Calls the external command cwd.
10959  
10960  =back
10961  
10962  =head2 Note on the format of the urllist parameter
10963  
10964  urllist parameters are URLs according to RFC 1738. We do a little
10965  guessing if your URL is not compliant, but if you have problems with
10966  C<file> URLs, please try the correct format. Either:
10967  
10968      file://localhost/whatever/ftp/pub/CPAN/
10969  
10970  or
10971  
10972      file:///home/ftp/pub/CPAN/
10973  
10974  =head2 The urllist parameter has CD-ROM support
10975  
10976  The C<urllist> parameter of the configuration table contains a list of
10977  URLs that are to be used for downloading. If the list contains any
10978  C<file> URLs, CPAN always tries to get files from there first. This
10979  feature is disabled for index files. So the recommendation for the
10980  owner of a CD-ROM with CPAN contents is: include your local, possibly
10981  outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10982  
10983    o conf urllist push file://localhost/CDROM/CPAN
10984  
10985  CPAN.pm will then fetch the index files from one of the CPAN sites
10986  that come at the beginning of urllist. It will later check for each
10987  module if there is a local copy of the most recent version.
10988  
10989  Another peculiarity of urllist is that the site that we could
10990  successfully fetch the last file from automatically gets a preference
10991  token and is tried as the first site for the next request. So if you
10992  add a new site at runtime it may happen that the previously preferred
10993  site will be tried another time. This means that if you want to disallow
10994  a site for the next transfer, it must be explicitly removed from
10995  urllist.
10996  
10997  =head2 Maintaining the urllist parameter
10998  
10999  If you have YAML.pm (or some other YAML module configured in
11000  C<yaml_module>) installed, CPAN.pm collects a few statistical data
11001  about recent downloads. You can view the statistics with the C<hosts>
11002  command or inspect them directly by looking into the C<FTPstats.yml>
11003  file in your C<cpan_home> directory.
11004  
11005  To get some interesting statistics it is recommended to set the
11006  C<randomize_urllist> parameter that introduces some amount of
11007  randomness into the URL selection.
11008  
11009  =head2 The C<requires> and C<build_requires> dependency declarations
11010  
11011  Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11012  a distribution are treated differently depending on the config
11013  variable C<build_requires_install_policy>. By setting
11014  C<build_requires_install_policy> to C<no> such a module is not being
11015  installed. It is only built and tested and then kept in the list of
11016  tested but uninstalled modules. As such it is available during the
11017  build of the dependent module by integrating the path to the
11018  C<blib/arch> and C<blib/lib> directories in the environment variable
11019  PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11020  both modules declared as C<requires> and those declared as
11021  C<build_requires> are treated alike. By setting to C<ask/yes> or
11022  C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11023  
11024  =head2 Configuration for individual distributions (I<Distroprefs>)
11025  
11026  (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11027  still considered beta quality)
11028  
11029  Distributions on the CPAN usually behave according to what we call the
11030  CPAN mantra. Or since the event of Module::Build we should talk about
11031  two mantras:
11032  
11033      perl Makefile.PL     perl Build.PL
11034      make                 ./Build
11035      make test            ./Build test
11036      make install         ./Build install
11037  
11038  But some modules cannot be built with this mantra. They try to get
11039  some extra data from the user via the environment, extra arguments or
11040  interactively thus disturbing the installation of large bundles like
11041  Phalanx100 or modules with many dependencies like Plagger.
11042  
11043  The distroprefs system of C<CPAN.pm> addresses this problem by
11044  allowing the user to specify extra informations and recipes in YAML
11045  files to either
11046  
11047  =over
11048  
11049  =item
11050  
11051  pass additional arguments to one of the four commands,
11052  
11053  =item
11054  
11055  set environment variables
11056  
11057  =item
11058  
11059  instantiate an Expect object that reads from the console, waits for
11060  some regular expressions and enters some answers
11061  
11062  =item
11063  
11064  temporarily override assorted C<CPAN.pm> configuration variables
11065  
11066  =item
11067  
11068  specify dependencies that the original maintainer forgot to specify
11069  
11070  =item
11071  
11072  disable the installation of an object altogether
11073  
11074  =back
11075  
11076  See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11077  distribution in the C<distroprefs/> directory for examples.
11078  
11079  =head2 Filenames
11080  
11081  The YAML files themselves must have the C<.yml> extension, all other
11082  files are ignored (for two exceptions see I<Fallback Data::Dumper and
11083  Storable> below). The containing directory can be specified in
11084  C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11085  prefs_dir> in the CPAN shell to set and activate the distroprefs
11086  system.
11087  
11088  Every YAML file may contain arbitrary documents according to the YAML
11089  specification and every single document is treated as an entity that
11090  can specify the treatment of a single distribution.
11091  
11092  The names of the files can be picked freely, C<CPAN.pm> always reads
11093  all files (in alphabetical order) and takes the key C<match> (see
11094  below in I<Language Specs>) as a hashref containing match criteria
11095  that determine if the current distribution matches the YAML document
11096  or not.
11097  
11098  =head2 Fallback Data::Dumper and Storable
11099  
11100  If neither your configured C<yaml_module> nor YAML.pm is installed
11101  CPAN.pm falls back to using Data::Dumper and Storable and looks for
11102  files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11103  directory. These files are expected to contain one or more hashrefs.
11104  For Data::Dumper generated files, this is expected to be done with by
11105  defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11106  with the command
11107  
11108      ysh < somefile.yml > somefile.dd
11109  
11110  For Storable files the rule is that they must be constructed such that
11111  C<Storable::retrieve(file)> returns an array reference and the array
11112  elements represent one distropref object each. The conversion from
11113  YAML would look like so:
11114  
11115      perl -MYAML=LoadFile -MStorable=nstore -e '
11116          @y=LoadFile(shift);
11117          nstore(\@y, shift)' somefile.yml somefile.st
11118  
11119  In bootstrapping situations it is usually sufficient to translate only
11120  a few YAML files to Data::Dumper for the crucial modules like
11121  C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11122  over Data::Dumper, remember to pull out a Storable version that writes
11123  an older format than all the other Storable versions that will need to
11124  read them.
11125  
11126  =head2 Blueprint
11127  
11128  The following example contains all supported keywords and structures
11129  with the exception of C<eexpect> which can be used instead of
11130  C<expect>.
11131  
11132    ---
11133    comment: "Demo"
11134    match:
11135      module: "Dancing::Queen"
11136      distribution: "^CHACHACHA/Dancing-"
11137      perl: "/usr/local/cariba-perl/bin/perl"
11138      perlconfig:
11139        archname: "freebsd"
11140    disabled: 1
11141    cpanconfig:
11142      make: gmake
11143    pl:
11144      args:
11145        - "--somearg=specialcase"
11146  
11147      env: {}
11148  
11149      expect:
11150        - "Which is your favorite fruit"
11151        - "apple\n"
11152  
11153    make:
11154      args:
11155        - all
11156        - extra-all
11157  
11158      env: {}
11159  
11160      expect: []
11161  
11162      commendline: "echo SKIPPING make"
11163  
11164    test:
11165      args: []
11166  
11167      env: {}
11168  
11169      expect: []
11170  
11171    install:
11172      args: []
11173  
11174      env:
11175        WANT_TO_INSTALL: YES
11176  
11177      expect:
11178        - "Do you really want to install"
11179        - "y\n"
11180  
11181    patches:
11182      - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11183  
11184    depends:
11185      configure_requires:
11186        LWP: 5.8
11187      build_requires:
11188        Test::Exception: 0.25
11189      requires:
11190        Spiffy: 0.30
11191  
11192  
11193  =head2 Language Specs
11194  
11195  Every YAML document represents a single hash reference. The valid keys
11196  in this hash are as follows:
11197  
11198  =over
11199  
11200  =item comment [scalar]
11201  
11202  A comment
11203  
11204  =item cpanconfig [hash]
11205  
11206  Temporarily override assorted C<CPAN.pm> configuration variables.
11207  
11208  Supported are: C<build_requires_install_policy>, C<check_sigs>,
11209  C<make>, C<make_install_make_command>, C<prefer_installer>,
11210  C<test_report>. Please report as a bug when you need another one
11211  supported.
11212  
11213  =item depends [hash] *** EXPERIMENTAL FEATURE ***
11214  
11215  All three types, namely C<configure_requires>, C<build_requires>, and
11216  C<requires> are supported in the way specified in the META.yml
11217  specification. The current implementation I<merges> the specified
11218  dependencies with those declared by the package maintainer. In a
11219  future implementation this may be changed to override the original
11220  declaration.
11221  
11222  =item disabled [boolean]
11223  
11224  Specifies that this distribution shall not be processed at all.
11225  
11226  =item goto [string]
11227  
11228  The canonical name of a delegate distribution that shall be installed
11229  instead. Useful when a new version, although it tests OK itself,
11230  breaks something else or a developer release or a fork is already
11231  uploaded that is better than the last released version.
11232  
11233  =item install [hash]
11234  
11235  Processing instructions for the C<make install> or C<./Build install>
11236  phase of the CPAN mantra. See below under I<Processiong Instructions>.
11237  
11238  =item make [hash]
11239  
11240  Processing instructions for the C<make> or C<./Build> phase of the
11241  CPAN mantra. See below under I<Processiong Instructions>.
11242  
11243  =item match [hash]
11244  
11245  A hashref with one or more of the keys C<distribution>, C<modules>,
11246  C<perl>, and C<perlconfig> that specify if a document is targeted at a
11247  specific CPAN distribution or installation.
11248  
11249  The corresponding values are interpreted as regular expressions. The
11250  C<distribution> related one will be matched against the canonical
11251  distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11252  
11253  The C<module> related one will be matched against I<all> modules
11254  contained in the distribution until one module matches.
11255  
11256  The C<perl> related one will be matched against C<$^X> (but with the
11257  absolute path).
11258  
11259  The value associated with C<perlconfig> is itself a hashref that is
11260  matched against corresponding values in the C<%Config::Config> hash
11261  living in the C< Config.pm > module.
11262  
11263  If more than one restriction of C<module>, C<distribution>, and
11264  C<perl> is specified, the results of the separately computed match
11265  values must all match. If this is the case then the hashref
11266  represented by the YAML document is returned as the preference
11267  structure for the current distribution.
11268  
11269  =item patches [array]
11270  
11271  An array of patches on CPAN or on the local disk to be applied in
11272  order via the external patch program. If the value for the C<-p>
11273  parameter is C<0> or C<1> is determined by reading the patch
11274  beforehand.
11275  
11276  Note: if the C<applypatch> program is installed and C<CPAN::Config>
11277  knows about it B<and> a patch is written by the C<makepatch> program,
11278  then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11279  and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11280  distribution.
11281  
11282  =item pl [hash]
11283  
11284  Processing instructions for the C<perl Makefile.PL> or C<perl
11285  Build.PL> phase of the CPAN mantra. See below under I<Processiong
11286  Instructions>.
11287  
11288  =item test [hash]
11289  
11290  Processing instructions for the C<make test> or C<./Build test> phase
11291  of the CPAN mantra. See below under I<Processiong Instructions>.
11292  
11293  =back
11294  
11295  =head2 Processing Instructions
11296  
11297  =over
11298  
11299  =item args [array]
11300  
11301  Arguments to be added to the command line
11302  
11303  =item commandline
11304  
11305  A full commandline that will be executed as it stands by a system
11306  call. During the execution the environment variable PERL will is set
11307  to $^X (but with an absolute path). If C<commandline> is specified,
11308  the content of C<args> is not used.
11309  
11310  =item eexpect [hash]
11311  
11312  Extended C<expect>. This is a hash reference with four allowed keys,
11313  C<mode>, C<timeout>, C<reuse>, and C<talk>.
11314  
11315  C<mode> may have the values C<deterministic> for the case where all
11316  questions come in the order written down and C<anyorder> for the case
11317  where the questions may come in any order. The default mode is
11318  C<deterministic>.
11319  
11320  C<timeout> denotes a timeout in seconds. Floating point timeouts are
11321  OK. In the case of a C<mode=deterministic> the timeout denotes the
11322  timeout per question, in the case of C<mode=anyorder> it denotes the
11323  timeout per byte received from the stream or questions.
11324  
11325  C<talk> is a reference to an array that contains alternating questions
11326  and answers. Questions are regular expressions and answers are literal
11327  strings. The Expect module will then watch the stream coming from the
11328  execution of the external program (C<perl Makefile.PL>, C<perl
11329  Build.PL>, C<make>, etc.).
11330  
11331  In the case of C<mode=deterministic> the CPAN.pm will inject the
11332  according answer as soon as the stream matches the regular expression.
11333  
11334  In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11335  as the timeout is reached for the next byte in the input stream. In
11336  this mode you can use the C<reuse> parameter to decide what shall
11337  happen with a question-answer pair after it has been used. In the
11338  default case (reuse=0) it is removed from the array, so it cannot be
11339  used again accidentally. In this case, if you want to answer the
11340  question C<Do you really want to do that> several times, then it must
11341  be included in the array at least as often as you want this answer to
11342  be given. Setting the parameter C<reuse> to 1 makes this repetition
11343  unnecessary.
11344  
11345  =item env [hash]
11346  
11347  Environment variables to be set during the command
11348  
11349  =item expect [array]
11350  
11351  C<< expect: <array> >> is a short notation for
11352  
11353    eexpect:
11354      mode: deterministic
11355      timeout: 15
11356      talk: <array>
11357  
11358  =back
11359  
11360  =head2 Schema verification with C<Kwalify>
11361  
11362  If you have the C<Kwalify> module installed (which is part of the
11363  Bundle::CPANxxl), then all your distroprefs files are checked for
11364  syntactical correctness.
11365  
11366  =head2 Example Distroprefs Files
11367  
11368  C<CPAN.pm> comes with a collection of example YAML files. Note that these
11369  are really just examples and should not be used without care because
11370  they cannot fit everybody's purpose. After all the authors of the
11371  packages that ask questions had a need to ask, so you should watch
11372  their questions and adjust the examples to your environment and your
11373  needs. You have beend warned:-)
11374  
11375  =head1 PROGRAMMER'S INTERFACE
11376  
11377  If you do not enter the shell, the available shell commands are both
11378  available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11379  functions in the calling package (C<install(...)>).  Before calling low-level
11380  commands it makes sense to initialize components of CPAN you need, e.g.:
11381  
11382    CPAN::HandleConfig->load;
11383    CPAN::Shell::setup_output;
11384    CPAN::Index->reload;
11385  
11386  High-level commands do such initializations automatically.
11387  
11388  There's currently only one class that has a stable interface -
11389  CPAN::Shell. All commands that are available in the CPAN shell are
11390  methods of the class CPAN::Shell. Each of the commands that produce
11391  listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11392  the IDs of all modules within the list.
11393  
11394  =over 2
11395  
11396  =item expand($type,@things)
11397  
11398  The IDs of all objects available within a program are strings that can
11399  be expanded to the corresponding real objects with the
11400  C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11401  list of CPAN::Module objects according to the C<@things> arguments
11402  given. In scalar context it only returns the first element of the
11403  list.
11404  
11405  =item expandany(@things)
11406  
11407  Like expand, but returns objects of the appropriate type, i.e.
11408  CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11409  CPAN::Distribution objects for distributions. Note: it does not expand
11410  to CPAN::Author objects.
11411  
11412  =item Programming Examples
11413  
11414  This enables the programmer to do operations that combine
11415  functionalities that are available in the shell.
11416  
11417      # install everything that is outdated on my disk:
11418      perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11419  
11420      # install my favorite programs if necessary:
11421      for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11422          CPAN::Shell->install($mod);
11423      }
11424  
11425      # list all modules on my disk that have no VERSION number
11426      for $mod (CPAN::Shell->expand("Module","/./")) {
11427          next unless $mod->inst_file;
11428          # MakeMaker convention for undefined $VERSION:
11429          next unless $mod->inst_version eq "undef";
11430          print "No VERSION in ", $mod->id, "\n";
11431      }
11432  
11433      # find out which distribution on CPAN contains a module:
11434      print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11435  
11436  Or if you want to write a cronjob to watch The CPAN, you could list
11437  all modules that need updating. First a quick and dirty way:
11438  
11439      perl -e 'use CPAN; CPAN::Shell->r;'
11440  
11441  If you don't want to get any output in the case that all modules are
11442  up to date, you can parse the output of above command for the regular
11443  expression //modules are up to date// and decide to mail the output
11444  only if it doesn't match. Ick?
11445  
11446  If you prefer to do it more in a programmer style in one single
11447  process, maybe something like this suits you better:
11448  
11449    # list all modules on my disk that have newer versions on CPAN
11450    for $mod (CPAN::Shell->expand("Module","/./")) {
11451      next unless $mod->inst_file;
11452      next if $mod->uptodate;
11453      printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11454          $mod->id, $mod->inst_version, $mod->cpan_version;
11455    }
11456  
11457  If that gives you too much output every day, you maybe only want to
11458  watch for three modules. You can write
11459  
11460    for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
11461  
11462  as the first line instead. Or you can combine some of the above
11463  tricks:
11464  
11465    # watch only for a new mod_perl module
11466    $mod = CPAN::Shell->expand("Module","mod_perl");
11467    exit if $mod->uptodate;
11468    # new mod_perl arrived, let me know all update recommendations
11469    CPAN::Shell->r;
11470  
11471  =back
11472  
11473  =head2 Methods in the other Classes
11474  
11475  =over 4
11476  
11477  =item CPAN::Author::as_glimpse()
11478  
11479  Returns a one-line description of the author
11480  
11481  =item CPAN::Author::as_string()
11482  
11483  Returns a multi-line description of the author
11484  
11485  =item CPAN::Author::email()
11486  
11487  Returns the author's email address
11488  
11489  =item CPAN::Author::fullname()
11490  
11491  Returns the author's name
11492  
11493  =item CPAN::Author::name()
11494  
11495  An alias for fullname
11496  
11497  =item CPAN::Bundle::as_glimpse()
11498  
11499  Returns a one-line description of the bundle
11500  
11501  =item CPAN::Bundle::as_string()
11502  
11503  Returns a multi-line description of the bundle
11504  
11505  =item CPAN::Bundle::clean()
11506  
11507  Recursively runs the C<clean> method on all items contained in the bundle.
11508  
11509  =item CPAN::Bundle::contains()
11510  
11511  Returns a list of objects' IDs contained in a bundle. The associated
11512  objects may be bundles, modules or distributions.
11513  
11514  =item CPAN::Bundle::force($method,@args)
11515  
11516  Forces CPAN to perform a task that it normally would have refused to
11517  do. Force takes as arguments a method name to be called and any number
11518  of additional arguments that should be passed to the called method.
11519  The internals of the object get the needed changes so that CPAN.pm
11520  does not refuse to take the action. The C<force> is passed recursively
11521  to all contained objects. See also the section above on the C<force>
11522  and the C<fforce> pragma.
11523  
11524  =item CPAN::Bundle::get()
11525  
11526  Recursively runs the C<get> method on all items contained in the bundle
11527  
11528  =item CPAN::Bundle::inst_file()
11529  
11530  Returns the highest installed version of the bundle in either @INC or
11531  C<$CPAN::Config->{cpan_home}>. Note that this is different from
11532  CPAN::Module::inst_file.
11533  
11534  =item CPAN::Bundle::inst_version()
11535  
11536  Like CPAN::Bundle::inst_file, but returns the $VERSION
11537  
11538  =item CPAN::Bundle::uptodate()
11539  
11540  Returns 1 if the bundle itself and all its members are uptodate.
11541  
11542  =item CPAN::Bundle::install()
11543  
11544  Recursively runs the C<install> method on all items contained in the bundle
11545  
11546  =item CPAN::Bundle::make()
11547  
11548  Recursively runs the C<make> method on all items contained in the bundle
11549  
11550  =item CPAN::Bundle::readme()
11551  
11552  Recursively runs the C<readme> method on all items contained in the bundle
11553  
11554  =item CPAN::Bundle::test()
11555  
11556  Recursively runs the C<test> method on all items contained in the bundle
11557  
11558  =item CPAN::Distribution::as_glimpse()
11559  
11560  Returns a one-line description of the distribution
11561  
11562  =item CPAN::Distribution::as_string()
11563  
11564  Returns a multi-line description of the distribution
11565  
11566  =item CPAN::Distribution::author
11567  
11568  Returns the CPAN::Author object of the maintainer who uploaded this
11569  distribution
11570  
11571  =item CPAN::Distribution::pretty_id()
11572  
11573  Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11574  author's PAUSE ID and TARBALL is the distribution filename.
11575  
11576  =item CPAN::Distribution::base_id()
11577  
11578  Returns the distribution filename without any archive suffix.  E.g
11579  "Foo-Bar-0.01"
11580  
11581  =item CPAN::Distribution::clean()
11582  
11583  Changes to the directory where the distribution has been unpacked and
11584  runs C<make clean> there.
11585  
11586  =item CPAN::Distribution::containsmods()
11587  
11588  Returns a list of IDs of modules contained in a distribution file.
11589  Only works for distributions listed in the 02packages.details.txt.gz
11590  file. This typically means that only the most recent version of a
11591  distribution is covered.
11592  
11593  =item CPAN::Distribution::cvs_import()
11594  
11595  Changes to the directory where the distribution has been unpacked and
11596  runs something like
11597  
11598      cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
11599  
11600  there.
11601  
11602  =item CPAN::Distribution::dir()
11603  
11604  Returns the directory into which this distribution has been unpacked.
11605  
11606  =item CPAN::Distribution::force($method,@args)
11607  
11608  Forces CPAN to perform a task that it normally would have refused to
11609  do. Force takes as arguments a method name to be called and any number
11610  of additional arguments that should be passed to the called method.
11611  The internals of the object get the needed changes so that CPAN.pm
11612  does not refuse to take the action. See also the section above on the
11613  C<force> and the C<fforce> pragma.
11614  
11615  =item CPAN::Distribution::get()
11616  
11617  Downloads the distribution from CPAN and unpacks it. Does nothing if
11618  the distribution has already been downloaded and unpacked within the
11619  current session.
11620  
11621  =item CPAN::Distribution::install()
11622  
11623  Changes to the directory where the distribution has been unpacked and
11624  runs the external command C<make install> there. If C<make> has not
11625  yet been run, it will be run first. A C<make test> will be issued in
11626  any case and if this fails, the install will be canceled. The
11627  cancellation can be avoided by letting C<force> run the C<install> for
11628  you.
11629  
11630  This install method has only the power to install the distribution if
11631  there are no dependencies in the way. To install an object and all of
11632  its dependencies, use CPAN::Shell->install.
11633  
11634  Note that install() gives no meaningful return value. See uptodate().
11635  
11636  =item CPAN::Distribution::install_tested()
11637  
11638  Install all the distributions that have been tested sucessfully but
11639  not yet installed. See also C<is_tested>.
11640  
11641  =item CPAN::Distribution::isa_perl()
11642  
11643  Returns 1 if this distribution file seems to be a perl distribution.
11644  Normally this is derived from the file name only, but the index from
11645  CPAN can contain a hint to achieve a return value of true for other
11646  filenames too.
11647  
11648  =item CPAN::Distribution::is_tested()
11649  
11650  List all the distributions that have been tested sucessfully but not
11651  yet installed. See also C<install_tested>.
11652  
11653  =item CPAN::Distribution::look()
11654  
11655  Changes to the directory where the distribution has been unpacked and
11656  opens a subshell there. Exiting the subshell returns.
11657  
11658  =item CPAN::Distribution::make()
11659  
11660  First runs the C<get> method to make sure the distribution is
11661  downloaded and unpacked. Changes to the directory where the
11662  distribution has been unpacked and runs the external commands C<perl
11663  Makefile.PL> or C<perl Build.PL> and C<make> there.
11664  
11665  =item CPAN::Distribution::perldoc()
11666  
11667  Downloads the pod documentation of the file associated with a
11668  distribution (in html format) and runs it through the external
11669  command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11670  isn't available, it converts it to plain text with external
11671  command html2text and runs it through the pager specified
11672  in C<$CPAN::Config->{pager}>
11673  
11674  =item CPAN::Distribution::prefs()
11675  
11676  Returns the hash reference from the first matching YAML file that the
11677  user has deposited in the C<prefs_dir/> directory. The first
11678  succeeding match wins. The files in the C<prefs_dir/> are processed
11679  alphabetically and the canonical distroname (e.g.
11680  AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11681  stored in the $root->{match}{distribution} attribute value.
11682  Additionally all module names contained in a distribution are matched
11683  agains the regular expressions in the $root->{match}{module} attribute
11684  value. The two match values are ANDed together. Each of the two
11685  attributes are optional.
11686  
11687  =item CPAN::Distribution::prereq_pm()
11688  
11689  Returns the hash reference that has been announced by a distribution
11690  as the the C<requires> and C<build_requires> elements. These can be
11691  declared either by the C<META.yml> (if authoritative) or can be
11692  deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11693  or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11694  a comment in the produced C<Makefile>. I<Note>: this method only works
11695  after an attempt has been made to C<make> the distribution. Returns
11696  undef otherwise.
11697  
11698  =item CPAN::Distribution::readme()
11699  
11700  Downloads the README file associated with a distribution and runs it
11701  through the pager specified in C<$CPAN::Config->{pager}>.
11702  
11703  =item CPAN::Distribution::reports()
11704  
11705  Downloads report data for this distribution from cpantesters.perl.org
11706  and displays a subset of them.
11707  
11708  =item CPAN::Distribution::read_yaml()
11709  
11710  Returns the content of the META.yml of this distro as a hashref. Note:
11711  works only after an attempt has been made to C<make> the distribution.
11712  Returns undef otherwise. Also returns undef if the content of META.yml
11713  is not authoritative. (The rules about what exactly makes the content
11714  authoritative are still in flux.)
11715  
11716  =item CPAN::Distribution::test()
11717  
11718  Changes to the directory where the distribution has been unpacked and
11719  runs C<make test> there.
11720  
11721  =item CPAN::Distribution::uptodate()
11722  
11723  Returns 1 if all the modules contained in the distribution are
11724  uptodate. Relies on containsmods.
11725  
11726  =item CPAN::Index::force_reload()
11727  
11728  Forces a reload of all indices.
11729  
11730  =item CPAN::Index::reload()
11731  
11732  Reloads all indices if they have not been read for more than
11733  C<$CPAN::Config->{index_expire}> days.
11734  
11735  =item CPAN::InfoObj::dump()
11736  
11737  CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11738  inherit this method. It prints the data structure associated with an
11739  object. Useful for debugging. Note: the data structure is considered
11740  internal and thus subject to change without notice.
11741  
11742  =item CPAN::Module::as_glimpse()
11743  
11744  Returns a one-line description of the module in four columns: The
11745  first column contains the word C<Module>, the second column consists
11746  of one character: an equals sign if this module is already installed
11747  and uptodate, a less-than sign if this module is installed but can be
11748  upgraded, and a space if the module is not installed. The third column
11749  is the name of the module and the fourth column gives maintainer or
11750  distribution information.
11751  
11752  =item CPAN::Module::as_string()
11753  
11754  Returns a multi-line description of the module
11755  
11756  =item CPAN::Module::clean()
11757  
11758  Runs a clean on the distribution associated with this module.
11759  
11760  =item CPAN::Module::cpan_file()
11761  
11762  Returns the filename on CPAN that is associated with the module.
11763  
11764  =item CPAN::Module::cpan_version()
11765  
11766  Returns the latest version of this module available on CPAN.
11767  
11768  =item CPAN::Module::cvs_import()
11769  
11770  Runs a cvs_import on the distribution associated with this module.
11771  
11772  =item CPAN::Module::description()
11773  
11774  Returns a 44 character description of this module. Only available for
11775  modules listed in The Module List (CPAN/modules/00modlist.long.html
11776  or 00modlist.long.txt.gz)
11777  
11778  =item CPAN::Module::distribution()
11779  
11780  Returns the CPAN::Distribution object that contains the current
11781  version of this module.
11782  
11783  =item CPAN::Module::dslip_status()
11784  
11785  Returns a hash reference. The keys of the hash are the letters C<D>,
11786  C<S>, C<L>, C<I>, and <P>, for development status, support level,
11787  language, interface and public licence respectively. The data for the
11788  DSLIP status are collected by pause.perl.org when authors register
11789  their namespaces. The values of the 5 hash elements are one-character
11790  words whose meaning is described in the table below. There are also 5
11791  hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11792  verbose value of the 5 status variables.
11793  
11794  Where the 'DSLIP' characters have the following meanings:
11795  
11796    D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11797      i   - Idea, listed to gain consensus or as a placeholder
11798      c   - under construction but pre-alpha (not yet released)
11799      a/b - Alpha/Beta testing
11800      R   - Released
11801      M   - Mature (no rigorous definition)
11802      S   - Standard, supplied with Perl 5
11803  
11804    S - Support Level:
11805      m   - Mailing-list
11806      d   - Developer
11807      u   - Usenet newsgroup comp.lang.perl.modules
11808      n   - None known, try comp.lang.perl.modules
11809      a   - abandoned; volunteers welcome to take over maintainance
11810  
11811    L - Language Used:
11812      p   - Perl-only, no compiler needed, should be platform independent
11813      c   - C and perl, a C compiler will be needed
11814      h   - Hybrid, written in perl with optional C code, no compiler needed
11815      +   - C++ and perl, a C++ compiler will be needed
11816      o   - perl and another language other than C or C++
11817  
11818    I - Interface Style
11819      f   - plain Functions, no references used
11820      h   - hybrid, object and function interfaces available
11821      n   - no interface at all (huh?)
11822      r   - some use of unblessed References or ties
11823      O   - Object oriented using blessed references and/or inheritance
11824  
11825    P - Public License
11826      p   - Standard-Perl: user may choose between GPL and Artistic
11827      g   - GPL: GNU General Public License
11828      l   - LGPL: "GNU Lesser General Public License" (previously known as
11829            "GNU Library General Public License")
11830      b   - BSD: The BSD License
11831      a   - Artistic license alone
11832      2   - Artistic license 2.0 or later
11833      o   - open source: appoved by www.opensource.org
11834      d   - allows distribution without restrictions
11835      r   - restricted distribtion
11836      n   - no license at all
11837  
11838  =item CPAN::Module::force($method,@args)
11839  
11840  Forces CPAN to perform a task that it normally would have refused to
11841  do. Force takes as arguments a method name to be called and any number
11842  of additional arguments that should be passed to the called method.
11843  The internals of the object get the needed changes so that CPAN.pm
11844  does not refuse to take the action. See also the section above on the
11845  C<force> and the C<fforce> pragma.
11846  
11847  =item CPAN::Module::get()
11848  
11849  Runs a get on the distribution associated with this module.
11850  
11851  =item CPAN::Module::inst_file()
11852  
11853  Returns the filename of the module found in @INC. The first file found
11854  is reported just like perl itself stops searching @INC when it finds a
11855  module.
11856  
11857  =item CPAN::Module::available_file()
11858  
11859  Returns the filename of the module found in PERL5LIB or @INC. The
11860  first file found is reported. The advantage of this method over
11861  C<inst_file> is that modules that have been tested but not yet
11862  installed are included because PERL5LIB keeps track of tested modules.
11863  
11864  =item CPAN::Module::inst_version()
11865  
11866  Returns the version number of the installed module in readable format.
11867  
11868  =item CPAN::Module::available_version()
11869  
11870  Returns the version number of the available module in readable format.
11871  
11872  =item CPAN::Module::install()
11873  
11874  Runs an C<install> on the distribution associated with this module.
11875  
11876  =item CPAN::Module::look()
11877  
11878  Changes to the directory where the distribution associated with this
11879  module has been unpacked and opens a subshell there. Exiting the
11880  subshell returns.
11881  
11882  =item CPAN::Module::make()
11883  
11884  Runs a C<make> on the distribution associated with this module.
11885  
11886  =item CPAN::Module::manpage_headline()
11887  
11888  If module is installed, peeks into the module's manpage, reads the
11889  headline and returns it. Moreover, if the module has been downloaded
11890  within this session, does the equivalent on the downloaded module even
11891  if it is not installed.
11892  
11893  =item CPAN::Module::perldoc()
11894  
11895  Runs a C<perldoc> on this module.
11896  
11897  =item CPAN::Module::readme()
11898  
11899  Runs a C<readme> on the distribution associated with this module.
11900  
11901  =item CPAN::Module::reports()
11902  
11903  Calls the reports() method on the associated distribution object.
11904  
11905  =item CPAN::Module::test()
11906  
11907  Runs a C<test> on the distribution associated with this module.
11908  
11909  =item CPAN::Module::uptodate()
11910  
11911  Returns 1 if the module is installed and up-to-date.
11912  
11913  =item CPAN::Module::userid()
11914  
11915  Returns the author's ID of the module.
11916  
11917  =back
11918  
11919  =head2 Cache Manager
11920  
11921  Currently the cache manager only keeps track of the build directory
11922  ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11923  deletes complete directories below C<build_dir> as soon as the size of
11924  all directories there gets bigger than $CPAN::Config->{build_cache}
11925  (in MB). The contents of this cache may be used for later
11926  re-installations that you intend to do manually, but will never be
11927  trusted by CPAN itself. This is due to the fact that the user might
11928  use these directories for building modules on different architectures.
11929  
11930  There is another directory ($CPAN::Config->{keep_source_where}) where
11931  the original distribution files are kept. This directory is not
11932  covered by the cache manager and must be controlled by the user. If
11933  you choose to have the same directory as build_dir and as
11934  keep_source_where directory, then your sources will be deleted with
11935  the same fifo mechanism.
11936  
11937  =head2 Bundles
11938  
11939  A bundle is just a perl module in the namespace Bundle:: that does not
11940  define any functions or methods. It usually only contains documentation.
11941  
11942  It starts like a perl module with a package declaration and a $VERSION
11943  variable. After that the pod section looks like any other pod with the
11944  only difference being that I<one special pod section> exists starting with
11945  (verbatim):
11946  
11947      =head1 CONTENTS
11948  
11949  In this pod section each line obeys the format
11950  
11951          Module_Name [Version_String] [- optional text]
11952  
11953  The only required part is the first field, the name of a module
11954  (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11955  of the line is optional. The comment part is delimited by a dash just
11956  as in the man page header.
11957  
11958  The distribution of a bundle should follow the same convention as
11959  other distributions.
11960  
11961  Bundles are treated specially in the CPAN package. If you say 'install
11962  Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11963  the modules in the CONTENTS section of the pod. You can install your
11964  own Bundles locally by placing a conformant Bundle file somewhere into
11965  your @INC path. The autobundle() command which is available in the
11966  shell interface does that for you by including all currently installed
11967  modules in a snapshot bundle file.
11968  
11969  =head1 PREREQUISITES
11970  
11971  If you have a local mirror of CPAN and can access all files with
11972  "file:" URLs, then you only need a perl better than perl5.003 to run
11973  this module. Otherwise Net::FTP is strongly recommended. LWP may be
11974  required for non-UNIX systems or if your nearest CPAN site is
11975  associated with a URL that is not C<ftp:>.
11976  
11977  If you have neither Net::FTP nor LWP, there is a fallback mechanism
11978  implemented for an external ftp command or for an external lynx
11979  command.
11980  
11981  =head1 UTILITIES
11982  
11983  =head2 Finding packages and VERSION
11984  
11985  This module presumes that all packages on CPAN
11986  
11987  =over 2
11988  
11989  =item *
11990  
11991  declare their $VERSION variable in an easy to parse manner. This
11992  prerequisite can hardly be relaxed because it consumes far too much
11993  memory to load all packages into the running program just to determine
11994  the $VERSION variable. Currently all programs that are dealing with
11995  version use something like this
11996  
11997      perl -MExtUtils::MakeMaker -le \
11998          'print MM->parse_version(shift)' filename
11999  
12000  If you are author of a package and wonder if your $VERSION can be
12001  parsed, please try the above method.
12002  
12003  =item *
12004  
12005  come as compressed or gzipped tarfiles or as zip files and contain a
12006  C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12007  without much enthusiasm).
12008  
12009  =back
12010  
12011  =head2 Debugging
12012  
12013  The debugging of this module is a bit complex, because we have
12014  interferences of the software producing the indices on CPAN, of the
12015  mirroring process on CPAN, of packaging, of configuration, of
12016  synchronicity, and of bugs within CPAN.pm.
12017  
12018  For debugging the code of CPAN.pm itself in interactive mode some more
12019  or less useful debugging aid can be turned on for most packages within
12020  CPAN.pm with one of
12021  
12022  =over 2
12023  
12024  =item o debug package...
12025  
12026  sets debug mode for packages.
12027  
12028  =item o debug -package...
12029  
12030  unsets debug mode for packages.
12031  
12032  =item o debug all
12033  
12034  turns debugging on for all packages.
12035  
12036  =item o debug number
12037  
12038  =back
12039  
12040  which sets the debugging packages directly. Note that C<o debug 0>
12041  turns debugging off.
12042  
12043  What seems quite a successful strategy is the combination of C<reload
12044  cpan> and the debugging switches. Add a new debug statement while
12045  running in the shell and then issue a C<reload cpan> and see the new
12046  debugging messages immediately without losing the current context.
12047  
12048  C<o debug> without an argument lists the valid package names and the
12049  current set of packages in debugging mode. C<o debug> has built-in
12050  completion support.
12051  
12052  For debugging of CPAN data there is the C<dump> command which takes
12053  the same arguments as make/test/install and outputs each object's
12054  Data::Dumper dump. If an argument looks like a perl variable and
12055  contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12056  Data::Dumper directly.
12057  
12058  =head2 Floppy, Zip, Offline Mode
12059  
12060  CPAN.pm works nicely without network too. If you maintain machines
12061  that are not networked at all, you should consider working with file:
12062  URLs. Of course, you have to collect your modules somewhere first. So
12063  you might use CPAN.pm to put together all you need on a networked
12064  machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12065  $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12066  of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12067  with this floppy. See also below the paragraph about CD-ROM support.
12068  
12069  =head2 Basic Utilities for Programmers
12070  
12071  =over 2
12072  
12073  =item has_inst($module)
12074  
12075  Returns true if the module is installed. Used to load all modules into
12076  the running CPAN.pm which are considered optional. The config variable
12077  C<dontload_list> can be used to intercept the C<has_inst()> call such
12078  that an optional module is not loaded despite being available. For
12079  example the following command will prevent that C<YAML.pm> is being
12080  loaded:
12081  
12082      cpan> o conf dontload_list push YAML
12083  
12084  See the source for details.
12085  
12086  =item has_usable($module)
12087  
12088  Returns true if the module is installed and is in a usable state. Only
12089  useful for a handful of modules that are used internally. See the
12090  source for details.
12091  
12092  =item instance($module)
12093  
12094  The constructor for all the singletons used to represent modules,
12095  distributions, authors and bundles. If the object already exists, this
12096  method returns the object, otherwise it calls the constructor.
12097  
12098  =back
12099  
12100  =head1 SECURITY
12101  
12102  There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12103  install foreign, unmasked, unsigned code on your machine. We compare
12104  to a checksum that comes from the net just as the distribution file
12105  itself. But we try to make it easy to add security on demand:
12106  
12107  =head2 Cryptographically signed modules
12108  
12109  Since release 1.77 CPAN.pm has been able to verify cryptographically
12110  signed module distributions using Module::Signature.  The CPAN modules
12111  can be signed by their authors, thus giving more security.  The simple
12112  unsigned MD5 checksums that were used before by CPAN protect mainly
12113  against accidental file corruption.
12114  
12115  You will need to have Module::Signature installed, which in turn
12116  requires that you have at least one of Crypt::OpenPGP module or the
12117  command-line F<gpg> tool installed.
12118  
12119  You will also need to be able to connect over the Internet to the public
12120  keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12121  
12122  The configuration parameter check_sigs is there to turn signature
12123  checking on or off.
12124  
12125  =head1 EXPORT
12126  
12127  Most functions in package CPAN are exported per default. The reason
12128  for this is that the primary use is intended for the cpan shell or for
12129  one-liners.
12130  
12131  =head1 ENVIRONMENT
12132  
12133  When the CPAN shell enters a subshell via the look command, it sets
12134  the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12135  already set.
12136  
12137  When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12138  to the ID of the running process. It also sets
12139  PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12140  happen with older versions of Module::Install.
12141  
12142  When running C<perl Makefile.PL>, the environment variable
12143  C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12144  C<Makefile.PL> that is being executed. This prevents runaway processes
12145  with newer versions of Module::Install.
12146  
12147  When the config variable ftp_passive is set, all downloads will be run
12148  with the environment variable FTP_PASSIVE set to this value. This is
12149  in general a good idea as it influences both Net::FTP and LWP based
12150  connections. The same effect can be achieved by starting the cpan
12151  shell with this environment variable set. For Net::FTP alone, one can
12152  also always set passive mode by running libnetcfg.
12153  
12154  =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12155  
12156  Populating a freshly installed perl with my favorite modules is pretty
12157  easy if you maintain a private bundle definition file. To get a useful
12158  blueprint of a bundle definition file, the command autobundle can be used
12159  on the CPAN shell command line. This command writes a bundle definition
12160  file for all modules that are installed for the currently running perl
12161  interpreter. It's recommended to run this command only once and from then
12162  on maintain the file manually under a private name, say
12163  Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12164  
12165      cpan> install Bundle::my_bundle
12166  
12167  then answer a few questions and then go out for a coffee.
12168  
12169  Maintaining a bundle definition file means keeping track of two
12170  things: dependencies and interactivity. CPAN.pm sometimes fails on
12171  calculating dependencies because not all modules define all MakeMaker
12172  attributes correctly, so a bundle definition file should specify
12173  prerequisites as early as possible. On the other hand, it's a bit
12174  annoying that many distributions need some interactive configuring. So
12175  what I try to accomplish in my private bundle file is to have the
12176  packages that need to be configured early in the file and the gentle
12177  ones later, so I can go out after a few minutes and leave CPAN.pm
12178  untended.
12179  
12180  =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12181  
12182  Thanks to Graham Barr for contributing the following paragraphs about
12183  the interaction between perl, and various firewall configurations. For
12184  further information on firewalls, it is recommended to consult the
12185  documentation that comes with the ncftp program. If you are unable to
12186  go through the firewall with a simple Perl setup, it is very likely
12187  that you can configure ncftp so that it works for your firewall.
12188  
12189  =head2 Three basic types of firewalls
12190  
12191  Firewalls can be categorized into three basic types.
12192  
12193  =over 4
12194  
12195  =item http firewall
12196  
12197  This is where the firewall machine runs a web server and to access the
12198  outside world you must do it via the web server. If you set environment
12199  variables like http_proxy or ftp_proxy to a values beginning with http://
12200  or in your web browser you have to set proxy information then you know
12201  you are running an http firewall.
12202  
12203  To access servers outside these types of firewalls with perl (even for
12204  ftp) you will need to use LWP.
12205  
12206  =item ftp firewall
12207  
12208  This where the firewall machine runs an ftp server. This kind of
12209  firewall will only let you access ftp servers outside the firewall.
12210  This is usually done by connecting to the firewall with ftp, then
12211  entering a username like "user@outside.host.com"
12212  
12213  To access servers outside these type of firewalls with perl you
12214  will need to use Net::FTP.
12215  
12216  =item One way visibility
12217  
12218  I say one way visibility as these firewalls try to make themselves look
12219  invisible to the users inside the firewall. An FTP data connection is
12220  normally created by sending the remote server your IP address and then
12221  listening for the connection. But the remote server will not be able to
12222  connect to you because of the firewall. So for these types of firewall
12223  FTP connections need to be done in a passive mode.
12224  
12225  There are two that I can think off.
12226  
12227  =over 4
12228  
12229  =item SOCKS
12230  
12231  If you are using a SOCKS firewall you will need to compile perl and link
12232  it with the SOCKS library, this is what is normally called a 'socksified'
12233  perl. With this executable you will be able to connect to servers outside
12234  the firewall as if it is not there.
12235  
12236  =item IP Masquerade
12237  
12238  This is the firewall implemented in the Linux kernel, it allows you to
12239  hide a complete network behind one IP address. With this firewall no
12240  special compiling is needed as you can access hosts directly.
12241  
12242  For accessing ftp servers behind such firewalls you usually need to
12243  set the environment variable C<FTP_PASSIVE> or the config variable
12244  ftp_passive to a true value.
12245  
12246  =back
12247  
12248  =back
12249  
12250  =head2 Configuring lynx or ncftp for going through a firewall
12251  
12252  If you can go through your firewall with e.g. lynx, presumably with a
12253  command such as
12254  
12255      /usr/local/bin/lynx -pscott:tiger
12256  
12257  then you would configure CPAN.pm with the command
12258  
12259      o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12260  
12261  That's all. Similarly for ncftp or ftp, you would configure something
12262  like
12263  
12264      o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12265  
12266  Your mileage may vary...
12267  
12268  =head1 FAQ
12269  
12270  =over 4
12271  
12272  =item 1)
12273  
12274  I installed a new version of module X but CPAN keeps saying,
12275  I have the old version installed
12276  
12277  Most probably you B<do> have the old version installed. This can
12278  happen if a module installs itself into a different directory in the
12279  @INC path than it was previously installed. This is not really a
12280  CPAN.pm problem, you would have the same problem when installing the
12281  module manually. The easiest way to prevent this behaviour is to add
12282  the argument C<UNINST=1> to the C<make install> call, and that is why
12283  many people add this argument permanently by configuring
12284  
12285    o conf make_install_arg UNINST=1
12286  
12287  =item 2)
12288  
12289  So why is UNINST=1 not the default?
12290  
12291  Because there are people who have their precise expectations about who
12292  may install where in the @INC path and who uses which @INC array. In
12293  fine tuned environments C<UNINST=1> can cause damage.
12294  
12295  =item 3)
12296  
12297  I want to clean up my mess, and install a new perl along with
12298  all modules I have. How do I go about it?
12299  
12300  Run the autobundle command for your old perl and optionally rename the
12301  resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12302  with the Configure option prefix, e.g.
12303  
12304      ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12305  
12306  Install the bundle file you produced in the first step with something like
12307  
12308      cpan> install Bundle::mybundle
12309  
12310  and you're done.
12311  
12312  =item 4)
12313  
12314  When I install bundles or multiple modules with one command
12315  there is too much output to keep track of.
12316  
12317  You may want to configure something like
12318  
12319    o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12320    o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12321  
12322  so that STDOUT is captured in a file for later inspection.
12323  
12324  
12325  =item 5)
12326  
12327  I am not root, how can I install a module in a personal directory?
12328  
12329  First of all, you will want to use your own configuration, not the one
12330  that your root user installed. If you do not have permission to write
12331  in the cpan directory that root has configured, you will be asked if
12332  you want to create your own config. Answering "yes" will bring you into
12333  CPAN's configuration stage, using the system config for all defaults except
12334  things that have to do with CPAN's work directory, saving your choices to
12335  your MyConfig.pm file.
12336  
12337  You can also manually initiate this process with the following command:
12338  
12339      % perl -MCPAN -e 'mkmyconfig'
12340  
12341  or by running
12342  
12343      mkmyconfig
12344  
12345  from the CPAN shell.
12346  
12347  You will most probably also want to configure something like this:
12348  
12349    o conf makepl_arg "LIB=~/myperl/lib \
12350                      INSTALLMAN1DIR=~/myperl/man/man1 \
12351                      INSTALLMAN3DIR=~/myperl/man/man3 \
12352                      INSTALLSCRIPT=~/myperl/bin \
12353                      INSTALLBIN=~/myperl/bin"
12354  
12355  and then (oh joy) the equivalent command for Module::Build. That would
12356  be
12357  
12358    o conf mbuildpl_arg "--lib=~/myperl/lib \
12359                      --installman1dir=~/myperl/man/man1 \
12360                      --installman3dir=~/myperl/man/man3 \
12361                      --installscript=~/myperl/bin \
12362                      --installbin=~/myperl/bin"
12363  
12364  You can make this setting permanent like all C<o conf> settings with
12365  C<o conf commit> or by setting C<auto_commit> beforehand.
12366  
12367  You will have to add ~/myperl/man to the MANPATH environment variable
12368  and also tell your perl programs to look into ~/myperl/lib, e.g. by
12369  including
12370  
12371    use lib "$ENV{HOME}/myperl/lib";
12372  
12373  or setting the PERL5LIB environment variable.
12374  
12375  While we're speaking about $ENV{HOME}, it might be worth mentioning,
12376  that for Windows we use the File::HomeDir module that provides an
12377  equivalent to the concept of the home directory on Unix.
12378  
12379  Another thing you should bear in mind is that the UNINST parameter can
12380  be dangerous when you are installing into a private area because you
12381  might accidentally remove modules that other people depend on that are
12382  not using the private area.
12383  
12384  =item 6)
12385  
12386  How to get a package, unwrap it, and make a change before building it?
12387  
12388  Have a look at the C<look> (!) command.
12389  
12390  =item 7)
12391  
12392  I installed a Bundle and had a couple of fails. When I
12393  retried, everything resolved nicely. Can this be fixed to work
12394  on first try?
12395  
12396  The reason for this is that CPAN does not know the dependencies of all
12397  modules when it starts out. To decide about the additional items to
12398  install, it just uses data found in the META.yml file or the generated
12399  Makefile. An undetected missing piece breaks the process. But it may
12400  well be that your Bundle installs some prerequisite later than some
12401  depending item and thus your second try is able to resolve everything.
12402  Please note, CPAN.pm does not know the dependency tree in advance and
12403  cannot sort the queue of things to install in a topologically correct
12404  order. It resolves perfectly well IF all modules declare the
12405  prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12406  the C<requires> stanza of Module::Build. For bundles which fail and
12407  you need to install often, it is recommended to sort the Bundle
12408  definition file manually.
12409  
12410  =item 8)
12411  
12412  In our intranet we have many modules for internal use. How
12413  can I integrate these modules with CPAN.pm but without uploading
12414  the modules to CPAN?
12415  
12416  Have a look at the CPAN::Site module.
12417  
12418  =item 9)
12419  
12420  When I run CPAN's shell, I get an error message about things in my
12421  /etc/inputrc (or ~/.inputrc) file.
12422  
12423  These are readline issues and can only be fixed by studying readline
12424  configuration on your architecture and adjusting the referenced file
12425  accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12426  and edit them. Quite often harmless changes like uppercasing or
12427  lowercasing some arguments solves the problem.
12428  
12429  =item 10)
12430  
12431  Some authors have strange characters in their names.
12432  
12433  Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12434  expecting ISO-8859-1 charset, a converter can be activated by setting
12435  term_is_latin to a true value in your config file. One way of doing so
12436  would be
12437  
12438      cpan> o conf term_is_latin 1
12439  
12440  If other charset support is needed, please file a bugreport against
12441  CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12442  the support or maybe UTF-8 terminals become widely available.
12443  
12444  Note: this config variable is deprecated and will be removed in a
12445  future version of CPAN.pm. It will be replaced with the conventions
12446  around the family of $LANG and $LC_* environment variables.
12447  
12448  =item 11)
12449  
12450  When an install fails for some reason and then I correct the error
12451  condition and retry, CPAN.pm refuses to install the module, saying
12452  C<Already tried without success>.
12453  
12454  Use the force pragma like so
12455  
12456    force install Foo::Bar
12457  
12458  Or you can use
12459  
12460    look Foo::Bar
12461  
12462  and then 'make install' directly in the subshell.
12463  
12464  =item 12)
12465  
12466  How do I install a "DEVELOPER RELEASE" of a module?
12467  
12468  By default, CPAN will install the latest non-developer release of a
12469  module. If you want to install a dev release, you have to specify the
12470  partial path starting with the author id to the tarball you wish to
12471  install, like so:
12472  
12473      cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
12474  
12475  Note that you can use the C<ls> command to get this path listed.
12476  
12477  =item 13)
12478  
12479  How do I install a module and all its dependencies from the commandline,
12480  without being prompted for anything, despite my CPAN configuration
12481  (or lack thereof)?
12482  
12483  CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
12484  if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12485  asked any questions at all (assuming the modules you are installing are
12486  nice about obeying that variable as well):
12487  
12488      % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12489  
12490  =item 14)
12491  
12492  How do I create a Module::Build based Build.PL derived from an
12493  ExtUtils::MakeMaker focused Makefile.PL?
12494  
12495  http://search.cpan.org/search?query=Module::Build::Convert
12496  
12497  http://www.refcnt.org/papers/module-build-convert
12498  
12499  =item 15)
12500  
12501  What's the best CPAN site for me?
12502  
12503  The urllist config parameter is yours. You can add and remove sites at
12504  will. You should find out which sites have the best uptodateness,
12505  bandwidth, reliability, etc. and are topologically close to you. Some
12506  people prefer fast downloads, others uptodateness, others reliability.
12507  You decide which to try in which order.
12508  
12509  Henk P. Penning maintains a site that collects data about CPAN sites:
12510  
12511    http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
12512  
12513  =item 16)
12514  
12515  Why do I get asked the same questions every time I start the shell?
12516  
12517  You can make your configuration changes permanent by calling the
12518  command C<o conf commit>. Alternatively set the C<auto_commit>
12519  variable to true by running C<o conf init auto_commit> and answering
12520  the following question with yes.
12521  
12522  =back
12523  
12524  =head1 COMPATIBILITY
12525  
12526  =head2 OLD PERL VERSIONS
12527  
12528  CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12529  newer versions. It is getting more and more difficult to get the
12530  minimal prerequisites working on older perls. It is close to
12531  impossible to get the whole Bundle::CPAN working there. If you're in
12532  the position to have only these old versions, be advised that CPAN is
12533  designed to work fine without the Bundle::CPAN installed.
12534  
12535  To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12536  compatible with ancient perls and that File::Temp is listed as a
12537  prerequisite but CPAN has reasonable workarounds if it is missing.
12538  
12539  =head2 CPANPLUS
12540  
12541  This module and its competitor, the CPANPLUS module, are both much
12542  cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12543  more modular but it was never tried to make it compatible with CPAN.pm.
12544  
12545  =head1 SECURITY ADVICE
12546  
12547  This software enables you to upgrade software on your computer and so
12548  is inherently dangerous because the newly installed software may
12549  contain bugs and may alter the way your computer works or even make it
12550  unusable. Please consider backing up your data before every upgrade.
12551  
12552  =head1 BUGS
12553  
12554  Please report bugs via L<http://rt.cpan.org/>
12555  
12556  Before submitting a bug, please make sure that the traditional method
12557  of building a Perl module package from a shell by following the
12558  installation instructions of that package still works in your
12559  environment.
12560  
12561  =head1 AUTHOR
12562  
12563  Andreas Koenig C<< <andk@cpan.org> >>
12564  
12565  =head1 LICENSE
12566  
12567  This program is free software; you can redistribute it and/or
12568  modify it under the same terms as Perl itself.
12569  
12570  See L<http://www.perl.com/perl/misc/Artistic.html>
12571  
12572  =head1 TRANSLATIONS
12573  
12574  Kawai,Takanori provides a Japanese translation of this manpage at
12575  L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
12576  
12577  =head1 SEE ALSO
12578  
12579  L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
12580  
12581  =cut
12582  
12583  


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1