lib/CPAN/Distribution.pm

   1 package CPAN::Distribution;
   2 use strict;
   3 use Cwd qw(chdir);
   4 use CPAN::Distroprefs;
   5 use CPAN::InfoObj;
   6 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
   7 use vars qw($VERSION);
   8 $VERSION = "1.93";
   9
  10 # Accessors
  11 sub cpan_comment {
  12     my $self = shift;
  13     my $ro = $self->ro or return;
  14     $ro->{CPAN_COMMENT}
  15 }
  16
  17 #-> CPAN::Distribution::undelay
  18 sub undelay {
  19     my $self = shift;
  20     for my $delayer (
  21                      "configure_requires_later",
  22                      "configure_requires_later_for",
  23                      "later",
  24                      "later_for",
  25                     ) {
  26         delete $self->{$delayer};
  27     }
  28 }
  29
  30 #-> CPAN::Distribution::is_dot_dist
  31 sub is_dot_dist {
  32     my($self) = @_;
  33     return substr($self->id,-1,1) eq ".";
  34 }
  35
  36 # add the A/AN/ stuff
  37 #-> CPAN::Distribution::normalize
  38 sub normalize {
  39     my($self,$s) = @_;
  40     $s = $self->id unless defined $s;
  41     if (substr($s,-1,1) eq ".") {
  42         # using a global because we are sometimes called as static method
  43         if (!$CPAN::META->{LOCK}
  44             && !$CPAN::Have_warned->{"$s is unlocked"}++
  45            ) {
  46             $CPAN::Frontend->mywarn("You are visiting the local directory
  47   '$s'
  48   without lock, take care that concurrent processes do not do likewise.\n");
  49             $CPAN::Frontend->mysleep(1);
  50         }
  51         if ($s eq ".") {
  52             $s = "$CPAN::iCwd/.";
  53         } elsif (File::Spec->file_name_is_absolute($s)) {
  54         } elsif (File::Spec->can("rel2abs")) {
  55             $s = File::Spec->rel2abs($s);
  56         } else {
  57             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
  58         }
  59         CPAN->debug("s[$s]") if $CPAN::DEBUG;
  60         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
  61             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
  62                 $_->{build_dir} = $s;
  63                 $_->{archived} = "local_directory";
  64                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
  65             }
  66         }
  67     } elsif (
  68         $s =~ tr|/|| == 1
  69         or
  70         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
  71        ) {
  72         return $s if $s =~ m:^N/A|^Contact Author: ;
  73         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
  74         CPAN->debug("s[$s]") if $CPAN::DEBUG;
  75     }
  76     $s;
  77 }
  78
  79 #-> sub CPAN::Distribution::author ;
  80 sub author {
  81     my($self) = @_;
  82     my($authorid);
  83     if (substr($self->id,-1,1) eq ".") {
  84         $authorid = "LOCAL";
  85     } else {
  86         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
  87     }
  88     CPAN::Shell->expand("Author",$authorid);
  89 }
  90
  91 # tries to get the yaml from CPAN instead of the distro itself:
  92 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
  93 sub fast_yaml {
  94     my($self) = @_;
  95     my $meta = $self->pretty_id;
  96     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
  97     my(@ls) = CPAN::Shell->globls($meta);
  98     my $norm = $self->normalize($meta);
  99
 100     my($local_file);
 101     my($local_wanted) =
 102         File::Spec->catfile(
 103                             $CPAN::Config->{keep_source_where},
 104                             "authors",
 105                             "id",
 106                             split(/\//,$norm)
 107                            );
 108     $self->debug("Doing localize") if $CPAN::DEBUG;
 109     unless ($local_file =
 110             CPAN::FTP->localize("authors/id/$norm",
 111                                 $local_wanted)) {
 112         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
 113     }
 114     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
 115 }
 116
 117 #-> sub CPAN::Distribution::cpan_userid
 118 sub cpan_userid {
 119     my $self = shift;
 120     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
 121         return $1;
 122     }
 123     return $self->SUPER::cpan_userid;
 124 }
 125
 126 #-> sub CPAN::Distribution::pretty_id
 127 sub pretty_id {
 128     my $self = shift;
 129     my $id = $self->id;
 130     return $id unless $id =~ m|^./../|;
 131     substr($id,5);
 132 }
 133
 134 #-> sub CPAN::Distribution::base_id
 135 sub base_id {
 136     my $self = shift;
 137     my $id = $self->pretty_id();
 138     my $base_id = File::Basename::basename($id);
 139     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
 140     return $base_id;
 141 }
 142
 143 #-> sub CPAN::Distribution::tested_ok_but_not_installed
 144 sub tested_ok_but_not_installed {
 145     my $self = shift;
 146     return (
 147            $self->{make_test}
 148         && $self->{build_dir}
 149         && (UNIVERSAL::can($self->{make_test},"failed") ?
 150              ! $self->{make_test}->failed :
 151              $self->{make_test} =~ /^YES/
 152             )
 153         && (
 154             !$self->{install}
 155             ||
 156             $self->{install}->failed
 157            )
 158     );
 159 }
 160
 161
 162 # mark as dirty/clean for the sake of recursion detection. $color=1
 163 # means "in use", $color=0 means "not in use anymore". $color=2 means
 164 # we have determined prereqs now and thus insist on passing this
 165 # through (at least) once again.
 166
 167 #-> sub CPAN::Distribution::color_cmd_tmps ;
 168 sub color_cmd_tmps {
 169     my($self) = shift;
 170     my($depth) = shift || 0;
 171     my($color) = shift || 0;
 172     my($ancestors) = shift || [];
 173     # a distribution needs to recurse into its prereq_pms
 174
 175     return if exists $self->{incommandcolor}
 176         && $color==1
 177         && $self->{incommandcolor}==$color;
 178     if ($depth>=$CPAN::MAX_RECURSION) {
 179         die(CPAN::Exception::RecursiveDependency->new($ancestors));
 180     }
 181     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
 182     my $prereq_pm = $self->prereq_pm;
 183     if (defined $prereq_pm) {
 184       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
 185                            keys %{$prereq_pm->{build_requires}||{}}) {
 186             next PREREQ if $pre eq "perl";
 187             my $premo;
 188             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
 189                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
 190                 $CPAN::Frontend->mysleep(2);
 191                 next PREREQ;
 192             }
 193             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
 194         }
 195     }
 196     if ($color==0) {
 197         delete $self->{sponsored_mods};
 198
 199         # as we are at the end of a command, we'll give up this
 200         # reminder of a broken test. Other commands may test this guy
 201         # again. Maybe 'badtestcnt' should be renamed to
 202         # 'make_test_failed_within_command'?
 203         delete $self->{badtestcnt};
 204     }
 205     $self->{incommandcolor} = $color;
 206 }
 207
 208 #-> sub CPAN::Distribution::as_string ;
 209 sub as_string {
 210     my $self = shift;
 211     $self->containsmods;
 212     $self->upload_date;
 213     $self->SUPER::as_string(@_);
 214 }
 215
 216 #-> sub CPAN::Distribution::containsmods ;
 217 sub containsmods {
 218     my $self = shift;
 219     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
 220     my $dist_id = $self->{ID};
 221     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
 222         my $mod_file = $mod->cpan_file or next;
 223         my $mod_id = $mod->{ID} or next;
 224         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
 225         # sleep 1;
 226         if ($CPAN::Signal) {
 227             delete $self->{CONTAINSMODS};
 228             return;
 229         }
 230         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
 231     }
 232     keys %{$self->{CONTAINSMODS}||={}};
 233 }
 234
 235 #-> sub CPAN::Distribution::upload_date ;
 236 sub upload_date {
 237     my $self = shift;
 238     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
 239     my(@local_wanted) = split(/\//,$self->id);
 240     my $filename = pop @local_wanted;
 241     push @local_wanted, "CHECKSUMS";
 242     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
 243     return unless $author;
 244     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
 245     return unless @dl;
 246     my($dirent) = grep { $_->[2] eq $filename } @dl;
 247     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
 248     return unless $dirent->[1];
 249     return $self->{UPLOAD_DATE} = $dirent->[1];
 250 }
 251
 252 #-> sub CPAN::Distribution::uptodate ;
 253 sub uptodate {
 254     my($self) = @_;
 255     my $c;
 256     foreach $c ($self->containsmods) {
 257         my $obj = CPAN::Shell->expandany($c);
 258         unless ($obj->uptodate) {
 259             my $id = $self->pretty_id;
 260             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
 261             return 0;
 262         }
 263     }
 264     return 1;
 265 }
 266
 267 #-> sub CPAN::Distribution::called_for ;
 268 sub called_for {
 269     my($self,$id) = @_;
 270     $self->{CALLED_FOR} = $id if defined $id;
 271     return $self->{CALLED_FOR};
 272 }
 273
 274 #-> sub CPAN::Distribution::get ;
 275 sub get {
 276     my($self) = @_;
 277     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
 278     if (my $goto = $self->prefs->{goto}) {
 279         $CPAN::Frontend->mywarn
 280             (sprintf(
 281                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
 282                      $goto,
 283                      $self->{prefs_file},
 284                      $self->{prefs_file_doc},
 285                     ));
 286         return $self->goto($goto);
 287     }
 288     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
 289                            ? $ENV{PERL5LIB}
 290                            : ($ENV{PERLLIB} || "");
 291     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
 292     $CPAN::META->set_perl5lib;
 293     local $ENV{MAKEFLAGS}; # protect us from outer make calls
 294
 295   EXCUSE: {
 296         my @e;
 297         my $goodbye_message;
 298         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
 299         if ($self->prefs->{disabled} && ! $self->{force_update}) {
 300             my $why = sprintf(
 301                               "Disabled via prefs file '%s' doc %d",
 302                               $self->{prefs_file},
 303                               $self->{prefs_file_doc},
 304                              );
 305             push @e, $why;
 306             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
 307             $goodbye_message = "[disabled] -- NA $why";
 308             # note: not intended to be persistent but at least visible
 309             # during this session
 310         } else {
 311             if (exists $self->{build_dir} && -d $self->{build_dir}
 312                 && ($self->{modulebuild}||$self->{writemakefile})
 313                ) {
 314                 # this deserves print, not warn:
 315                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
 316                                          "$self->{build_dir}\n"
 317                                         );
 318                 return 1;
 319             }
 320
 321             # although we talk about 'force' we shall not test on
 322             # force directly. New model of force tries to refrain from
 323             # direct checking of force.
 324             exists $self->{unwrapped} and (
 325                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
 326                                            $self->{unwrapped}->failed :
 327                                            $self->{unwrapped} =~ /^NO/
 328                                           )
 329                 and push @e, "Unwrapping had some problem, won't try again without force";
 330         }
 331         if (@e) {
 332             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
 333             if ($goodbye_message) {
 334                  $self->goodbye($goodbye_message);
 335             }
 336             return;
 337         }
 338     }
 339     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
 340
 341     my($local_file);
 342     unless ($self->{build_dir} && -d $self->{build_dir}) {
 343         $self->get_file_onto_local_disk;
 344         return if $CPAN::Signal;
 345         $self->check_integrity;
 346         return if $CPAN::Signal;
 347         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
 348         if (exists $self->{writemakefile} && ref $self->{writemakefile}
 349            && $self->{writemakefile}->can("failed") &&
 350            $self->{writemakefile}->failed) {
 351             return;
 352         }
 353         $packagedir ||= $self->{build_dir};
 354         $self->{build_dir} = $packagedir;
 355     }
 356
 357     if ($CPAN::Signal) {
 358         $self->safe_chdir($sub_wd);
 359         return;
 360     }
 361     return $self->choose_MM_or_MB($local_file);
 362 }
 363
 364 #-> CPAN::Distribution::get_file_onto_local_disk
 365 sub get_file_onto_local_disk {
 366     my($self) = @_;
 367
 368     return if $self->is_dot_dist;
 369     my($local_file);
 370     my($local_wanted) =
 371         File::Spec->catfile(
 372                             $CPAN::Config->{keep_source_where},
 373                             "authors",
 374                             "id",
 375                             split(/\//,$self->id)
 376                            );
 377
 378     $self->debug("Doing localize") if $CPAN::DEBUG;
 379     unless ($local_file =
 380             CPAN::FTP->localize("authors/id/$self->{ID}",
 381                                 $local_wanted)) {
 382         my $note = "";
 383         if ($CPAN::Index::DATE_OF_02) {
 384             $note = "Note: Current database in memory was generated ".
 385                 "on $CPAN::Index::DATE_OF_02\n";
 386         }
 387         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
 388     }
 389
 390     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
 391     $self->{localfile} = $local_file;
 392 }
 393
 394
 395 #-> CPAN::Distribution::check_integrity
 396 sub check_integrity {
 397     my($self) = @_;
 398
 399     return if $self->is_dot_dist;
 400     if ($CPAN::META->has_inst("Digest::SHA")) {
 401         $self->debug("Digest::SHA is installed, verifying");
 402         $self->verifyCHECKSUM;
 403     } else {
 404         $self->debug("Digest::SHA is NOT installed");
 405     }
 406 }
 407
 408 #-> CPAN::Distribution::run_preps_on_packagedir
 409 sub run_preps_on_packagedir {
 410     my($self) = @_;
 411     return if $self->is_dot_dist;
 412
 413     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
 414     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
 415     $self->safe_chdir($builddir);
 416     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
 417     File::Path::rmtree("tmp-$$");
 418     unless (mkdir "tmp-$$", 0755) {
 419         $CPAN::Frontend->unrecoverable_error(<<EOF);
 420 Couldn't mkdir '$builddir/tmp-$$': $!
 421
 422 Cannot continue: Please find the reason why I cannot make the
 423 directory
 424 $builddir/tmp-$$
 425 and fix the problem, then retry.
 426
 427 EOF
 428     }
 429     if ($CPAN::Signal) {
 430         return;
 431     }
 432     $self->safe_chdir("tmp-$$");
 433
 434     #
 435     # Unpack the goods
 436     #
 437     my $local_file = $self->{localfile};
 438     my $ct = eval{CPAN::Tarzip->new($local_file)};
 439     unless ($ct) {
 440         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
 441         delete $self->{build_dir};
 442         return;
 443     }
 444     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
 445         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
 446         $self->untar_me($ct);
 447     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
 448         $self->unzip_me($ct);
 449     } else {
 450         $self->{was_uncompressed}++ unless $ct->gtest();
 451         $local_file = $self->handle_singlefile($local_file);
 452     }
 453
 454     # we are still in the tmp directory!
 455     # Let's check if the package has its own directory.
 456     my $dh = DirHandle->new(File::Spec->curdir)
 457         or Carp::croak("Couldn't opendir .: $!");
 458     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
 459     if (grep { $_ eq "pax_global_header" } @readdir) {
 460         $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
 461 from the tarball '$local_file'.
 462 This is almost certainly an error. Please upgrade your tar.
 463 I'll ignore this file for now.
 464 See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
 465         $CPAN::Frontend->mysleep(5);
 466         @readdir = grep { $_ ne "pax_global_header" } @readdir;
 467     }
 468     $dh->close;
 469     my ($packagedir);
 470     # XXX here we want in each branch File::Temp to protect all build_dir directories
 471     if (CPAN->has_usable("File::Temp")) {
 472         my $tdir_base;
 473         my $from_dir;
 474         my @dirents;
 475         if (@readdir == 1 && -d $readdir[0]) {
 476             $tdir_base = $readdir[0];
 477             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
 478             my $dh2;
 479             unless ($dh2 = DirHandle->new($from_dir)) {
 480                 my($mode) = (stat $from_dir)[2];
 481                 my $why = sprintf
 482                     (
 483                      "Couldn't opendir '%s', mode '%o': %s",
 484                      $from_dir,
 485                      $mode,
 486                      $!,
 487                     );
 488                 $CPAN::Frontend->mywarn("$why\n");
 489                 $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
 490                 return;
 491             }
 492             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
 493         } else {
 494             my $userid = $self->cpan_userid;
 495             CPAN->debug("userid[$userid]");
 496             if (!$userid or $userid eq "N/A") {
 497                 $userid = "anon";
 498             }
 499             $tdir_base = $userid;
 500             $from_dir = File::Spec->curdir;
 501             @dirents = @readdir;
 502         }
 503         $packagedir = File::Temp::tempdir(
 504                                           "$tdir_base-XXXXXX",
 505                                           DIR => $builddir,
 506                                           CLEANUP => 0,
 507                                          );
 508         chmod 0777 &~ umask, $packagedir; # may fail
 509         my $f;
 510         for $f (@dirents) { # is already without "." and ".."
 511             my $from = File::Spec->catdir($from_dir,$f);
 512             my $to = File::Spec->catdir($packagedir,$f);
 513             unless (File::Copy::move($from,$to)) {
 514                 my $err = $!;
 515                 $from = File::Spec->rel2abs($from);
 516                 Carp::confess("Couldn't move $from to $to: $err");
 517             }
 518         }
 519     } else { # older code below, still better than nothing when there is no File::Temp
 520         my($distdir);
 521         if (@readdir == 1 && -d $readdir[0]) {
 522             $distdir = $readdir[0];
 523             $packagedir = File::Spec->catdir($builddir,$distdir);
 524             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
 525                 if $CPAN::DEBUG;
 526             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
 527                                                         "$packagedir\n");
 528             File::Path::rmtree($packagedir);
 529             unless (File::Copy::move($distdir,$packagedir)) {
 530                 $CPAN::Frontend->unrecoverable_error(<<EOF);
 531 Couldn't move '$distdir' to '$packagedir': $!
 532
 533 Cannot continue: Please find the reason why I cannot move
 534 $builddir/tmp-$$/$distdir
 535 to
 536 $packagedir
 537 and fix the problem, then retry
 538
 539 EOF
 540             }
 541             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
 542                                  $distdir,
 543                                  $packagedir,
 544                                  -e $packagedir,
 545                                  -d $packagedir,
 546                                 )) if $CPAN::DEBUG;
 547         } else {
 548             my $userid = $self->cpan_userid;
 549             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
 550             if (!$userid or $userid eq "N/A") {
 551                 $userid = "anon";
 552             }
 553             my $pragmatic_dir = $userid . '000';
 554             $pragmatic_dir =~ s/\W_//g;
 555             $pragmatic_dir++ while -d "../$pragmatic_dir";
 556             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
 557             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
 558             File::Path::mkpath($packagedir);
 559             my($f);
 560             for $f (@readdir) { # is already without "." and ".."
 561                 my $to = File::Spec->catdir($packagedir,$f);
 562                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
 563             }
 564         }
 565     }
 566     $self->{build_dir} = $packagedir;
 567     $self->safe_chdir($builddir);
 568     File::Path::rmtree("tmp-$$");
 569
 570     $self->safe_chdir($packagedir);
 571     $self->_signature_business();
 572     $self->safe_chdir($builddir);
 573
 574     return($packagedir,$local_file);
 575 }
 576
 577 #-> sub CPAN::Distribution::parse_meta_yml ;
 578 sub parse_meta_yml {
 579     my($self) = @_;
 580     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
 581     my $yaml = File::Spec->catfile($build_dir,"META.yml");
 582     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
 583     return unless -f $yaml;
 584     my $early_yaml;
 585     eval {
 586         require Parse::CPAN::Meta;
 587         $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0];
 588     };
 589     unless ($early_yaml) {
 590         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
 591     }
 592     unless ($early_yaml) {
 593         return;
 594     }
 595     return $early_yaml;
 596 }
 597
 598 #-> sub CPAN::Distribution::satisfy_requires ;
 599 sub satisfy_requires {
 600     my ($self) = @_;
 601     if (my @prereq = $self->unsat_prereq("later")) {
 602         if ($prereq[0][0] eq "perl") {
 603             my $need = "requires perl '$prereq[0][1]'";
 604             my $id = $self->pretty_id;
 605             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
 606             $self->{make} = CPAN::Distrostatus->new("NO $need");
 607             $self->store_persistent_state;
 608             die "[prereq] -- NOT OK\n";
 609         } else {
 610             my $follow = eval { $self->follow_prereqs("later",@prereq); };
 611             if (0) {
 612             } elsif ($follow) {
 613                 # signal success to the queuerunner
 614                 return 1;
 615             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
 616                 $CPAN::Frontend->mywarn($@);
 617                 die "[depend] -- NOT OK\n";
 618             }
 619         }
 620     }
 621 }
 622
 623 #-> sub CPAN::Distribution::satisfy_configure_requires ;
 624 sub satisfy_configure_requires {
 625     my($self) = @_;
 626     my $enable_configure_requires = 1;
 627     if (!$enable_configure_requires) {
 628         return 1;
 629         # if we return 1 here, everything is as before we introduced
 630         # configure_requires that means, things with
 631         # configure_requires simply fail, all others succeed
 632     }
 633     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
 634     if ($self->{configure_requires_later}) {
 635         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
 636             if ($self->{configure_requires_later_for}{$k}>1) {
 637                 # we must not come here a second time
 638                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
 639                 require YAML::Syck;
 640                 $CPAN::Frontend->mydie
 641                     (
 642                      YAML::Syck::Dump
 643                      ({self=>$self, prereq=>\@prereq})
 644                     );
 645             }
 646         }
 647     }
 648     if ($prereq[0][0] eq "perl") {
 649         my $need = "requires perl '$prereq[0][1]'";
 650         my $id = $self->pretty_id;
 651         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
 652         $self->{make} = CPAN::Distrostatus->new("NO $need");
 653         $self->store_persistent_state;
 654         return $self->goodbye("[prereq] -- NOT OK");
 655     } else {
 656         my $follow = eval {
 657             $self->follow_prereqs("configure_requires_later", @prereq);
 658         };
 659         if (0) {
 660         } elsif ($follow) {
 661             return;
 662         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
 663             $CPAN::Frontend->mywarn($@);
 664             return $self->goodbye("[depend] -- NOT OK");
 665         }
 666     }
 667     die "never reached";
 668 }
 669
 670 #-> sub CPAN::Distribution::choose_MM_or_MB ;
 671 sub choose_MM_or_MB {
 672     my($self,$local_file) = @_;
 673     $self->satisfy_configure_requires() or return;
 674     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
 675     my($mpl_exists) = -f $mpl;
 676     unless ($mpl_exists) {
 677         # NFS has been reported to have racing problems after the
 678         # renaming of a directory in some environments.
 679         # This trick helps.
 680         $CPAN::Frontend->mysleep(1);
 681         my $mpldh = DirHandle->new($self->{build_dir})
 682             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
 683         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
 684         $mpldh->close;
 685     }
 686     my $prefer_installer = "eumm"; # eumm|mb
 687     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
 688         if ($mpl_exists) { # they *can* choose
 689             if ($CPAN::META->has_inst("Module::Build")) {
 690                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
 691                                                                      q{prefer_installer});
 692             }
 693         } else {
 694             $prefer_installer = "mb";
 695         }
 696     }
 697     return unless $self->patch;
 698     if (lc($prefer_installer) eq "rand") {
 699         $prefer_installer = rand()<.5 ? "eumm" : "mb";
 700     }
 701     if (lc($prefer_installer) eq "mb") {
 702         $self->{modulebuild} = 1;
 703     } elsif ($self->{archived} eq "patch") {
 704         # not an edge case, nothing to install for sure
 705         my $why = "A patch file cannot be installed";
 706         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
 707         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
 708     } elsif (! $mpl_exists) {
 709         $self->_edge_cases($mpl,$local_file);
 710     }
 711     if ($self->{build_dir}
 712         &&
 713         $CPAN::Config->{build_dir_reuse}
 714        ) {
 715         $self->store_persistent_state;
 716     }
 717     return $self;
 718 }
 719
 720 #-> CPAN::Distribution::store_persistent_state
 721 sub store_persistent_state {
 722     my($self) = @_;
 723     my $dir = $self->{build_dir};
 724     unless (File::Spec->canonpath(File::Basename::dirname($dir))
 725             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
 726         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
 727                                 "will not store persistent state\n");
 728         return;
 729     }
 730     my $file = sprintf "%s.yml", $dir;
 731     my $yaml_module = CPAN::_yaml_module();
 732     if ($CPAN::META->has_inst($yaml_module)) {
 733         CPAN->_yaml_dumpfile(
 734                              $file,
 735                              {
 736                               time => time,
 737                               perl => CPAN::_perl_fingerprint(),
 738                               distribution => $self,
 739                              }
 740                             );
 741     } else {
 742         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
 743                                 "will not store persistent state\n");
 744     }
 745 }
 746
 747 #-> CPAN::Distribution::try_download
 748 sub try_download {
 749     my($self,$patch) = @_;
 750     my $norm = $self->normalize($patch);
 751     my($local_wanted) =
 752         File::Spec->catfile(
 753                             $CPAN::Config->{keep_source_where},
 754                             "authors",
 755                             "id",
 756                             split(/\//,$norm),
 757                            );
 758     $self->debug("Doing localize") if $CPAN::DEBUG;
 759     return CPAN::FTP->localize("authors/id/$norm",
 760                                $local_wanted);
 761 }
 762
 763 {
 764     my $stdpatchargs = "";
 765     #-> CPAN::Distribution::patch
 766     sub patch {
 767         my($self) = @_;
 768         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
 769         my $patches = $self->prefs->{patches};
 770         $patches ||= "";
 771         $self->debug("patches[$patches]") if $CPAN::DEBUG;
 772         if ($patches) {
 773             return unless @$patches;
 774             $self->safe_chdir($self->{build_dir});
 775             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
 776             my $patchbin = $CPAN::Config->{patch};
 777             unless ($patchbin && length $patchbin) {
 778                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
 779                                        "Please run 'o conf init /patch/'\n\n");
 780             }
 781             unless (MM->maybe_command($patchbin)) {
 782                 $CPAN::Frontend->mydie("No external patch command available\n\n".
 783                                        "Please run 'o conf init /patch/'\n\n");
 784             }
 785             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
 786             local $ENV{PATCH_GET} = 0; # formerly known as -g0
 787             unless ($stdpatchargs) {
 788                 my $system = "$patchbin --version |";
 789                 local *FH;
 790                 open FH, $system or die "Could not fork '$system': $!";
 791                 local $/ = "\n";
 792                 my $pversion;
 793               PARSEVERSION: while (<FH>) {
 794                     if (/^patch\s+([\d\.]+)/) {
 795                         $pversion = $1;
 796                         last PARSEVERSION;
 797                     }
 798                 }
 799                 if ($pversion) {
 800                     $stdpatchargs = "-N --fuzz=3";
 801                 } else {
 802                     $stdpatchargs = "-N";
 803                 }
 804             }
 805             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
 806             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
 807             my $patches_dir = $CPAN::Config->{patches_dir};
 808             for my $patch (@$patches) {
 809                 if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
 810                     my $f = File::Spec->catfile($patches_dir, $patch);
 811                     $patch = $f if -f $f;
 812                 }
 813                 unless (-f $patch) {
 814                     if (my $trydl = $self->try_download($patch)) {
 815                         $patch = $trydl;
 816                     } else {
 817                         my $fail = "Could not find patch '$patch'";
 818                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
 819                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
 820                         delete $self->{build_dir};
 821                         return;
 822                     }
 823                 }
 824                 $CPAN::Frontend->myprint("  $patch\n");
 825                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
 826
 827                 my $pcommand;
 828                 my $ppp = $self->_patch_p_parameter($readfh);
 829                 if ($ppp eq "applypatch") {
 830                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
 831                 } else {
 832                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
 833                     $pcommand = "$patchbin $thispatchargs";
 834                 }
 835
 836                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
 837                 my $writefh = FileHandle->new;
 838                 $CPAN::Frontend->myprint("  $pcommand\n");
 839                 unless (open $writefh, "|$pcommand") {
 840                     my $fail = "Could not fork '$pcommand'";
 841                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
 842                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
 843                     delete $self->{build_dir};
 844                     return;
 845                 }
 846                 while (my $x = $readfh->READLINE) {
 847                     print $writefh $x;
 848                 }
 849                 unless (close $writefh) {
 850                     my $fail = "Could not apply patch '$patch'";
 851                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
 852                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
 853                     delete $self->{build_dir};
 854                     return;
 855                 }
 856             }
 857             $self->{patched}++;
 858         }
 859         return 1;
 860     }
 861 }
 862
 863 sub _patch_p_parameter {
 864     my($self,$fh) = @_;
 865     my $cnt_files   = 0;
 866     my $cnt_p0files = 0;
 867     local($_);
 868     while ($_ = $fh->READLINE) {
 869         if (
 870             $CPAN::Config->{applypatch}
 871             &&
 872             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
 873            ) {
 874             return "applypatch"
 875         }
 876         next unless /^[\*\+]{3}\s(\S+)/;
 877         my $file = $1;
 878         $cnt_files++;
 879         $cnt_p0files++ if -f $file;
 880         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
 881             if $CPAN::DEBUG;
 882     }
 883     return "-p1" unless $cnt_files;
 884     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
 885 }
 886
 887 #-> sub CPAN::Distribution::_edge_cases
 888 # with "configure" or "Makefile" or single file scripts
 889 sub _edge_cases {
 890     my($self,$mpl,$local_file) = @_;
 891     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
 892                          $mpl,
 893                          CPAN::anycwd(),
 894                         )) if $CPAN::DEBUG;
 895     my $build_dir = $self->{build_dir};
 896     my($configure) = File::Spec->catfile($build_dir,"Configure");
 897     if (-f $configure) {
 898         # do we have anything to do?
 899         $self->{configure} = $configure;
 900     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
 901         $CPAN::Frontend->mywarn(qq{
 902 Package comes with a Makefile and without a Makefile.PL.
 903 We\'ll try to build it with that Makefile then.
 904 });
 905         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
 906         $CPAN::Frontend->mysleep(2);
 907     } else {
 908         my $cf = $self->called_for || "unknown";
 909         if ($cf =~ m|/|) {
 910             $cf =~ s|.*/||;
 911             $cf =~ s|\W.*||;
 912         }
 913         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
 914         $cf = "unknown" unless length($cf);
 915         if (my $crud = $self->_contains_crud($build_dir)) {
 916             my $why = qq{Package contains $crud; not recognized as a perl package, giving up};
 917             $CPAN::Frontend->mywarn("$why\n");
 918             $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
 919             return;
 920         }
 921         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
 922   (The test -f "$mpl" returned false.)
 923   Writing one on our own (setting NAME to $cf)\a\n});
 924         $self->{had_no_makefile_pl}++;
 925         $CPAN::Frontend->mysleep(3);
 926
 927         # Writing our own Makefile.PL
 928
 929         my $exefile_stanza = "";
 930         if ($self->{archived} eq "maybe_pl") {
 931             $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
 932         }
 933
 934         my $fh = FileHandle->new;
 935         $fh->open(">$mpl")
 936             or Carp::croak("Could not open >$mpl: $!");
 937         $fh->print(
 938                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
 939 # because there was no Makefile.PL supplied.
 940 # Autogenerated on: }.scalar localtime().qq{
 941
 942 use ExtUtils::MakeMaker;
 943 WriteMakefile(
 944               NAME => q[$cf],$exefile_stanza
 945              );
 946 });
 947         $fh->close;
 948     }
 949 }
 950
 951 #-> CPAN;:Distribution::_contains_crud
 952 sub _contains_crud {
 953     my($self,$dir) = @_;
 954     my(@dirs, $dh, @files);
 955     opendir $dh, $dir or return;
 956     my $dirent;
 957     for $dirent (readdir $dh) {
 958         next if $dirent =~ /^\.\.?$/;
 959         my $path = File::Spec->catdir($dir,$dirent);
 960         if (-d $path) {
 961             push @dirs, $dirent;
 962         } elsif (-f $path) {
 963             push @files, $dirent;
 964         }
 965     }
 966     if (@dirs && @files) {
 967         return "both files[@files] and directories[@dirs]";
 968     } elsif (@files > 2) {
 969         return "several files[@files] but no Makefile.PL or Build.PL";
 970     }
 971     return;
 972 }
 973
 974 #-> CPAN;:Distribution::_exefile_stanza
 975 sub _exefile_stanza {
 976     my($self,$build_dir,$local_file) = @_;
 977
 978             my $fh = FileHandle->new;
 979             my $script_file = File::Spec->catfile($build_dir,$local_file);
 980             $fh->open($script_file)
 981                 or Carp::croak("Could not open script '$script_file': $!");
 982             local $/ = "\n";
 983             # name parsen und prereq
 984             my($state) = "poddir";
 985             my($name, $prereq) = ("", "");
 986             while (<$fh>) {
 987                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
 988                     if ($1 eq 'NAME') {
 989                         $state = "name";
 990                     } elsif ($1 eq 'PREREQUISITES') {
 991                         $state = "prereq";
 992                     }
 993                 } elsif ($state =~ m{^(name|prereq)$}) {
 994                     if (/^=/) {
 995                         $state = "poddir";
 996                     } elsif (/^\s*$/) {
 997                         # nop
 998                     } elsif ($state eq "name") {
 999                         if ($name eq "") {
1000                             ($name) = /^(\S+)/;
1001                             $state = "poddir";
1002                         }
1003                     } elsif ($state eq "prereq") {
1004                         $prereq .= $_;
1005                     }
1006                 } elsif (/^=cut\b/) {
1007                     last;
1008                 }
1009             }
1010             $fh->close;
1011
1012             for ($name) {
1013                 s{.*<}{};       # strip X<...>
1014                 s{>.*}{};
1015             }
1016             chomp $prereq;
1017             $prereq = join " ", split /\s+/, $prereq;
1018             my($PREREQ_PM) = join("\n", map {
1019                 s{.*<}{};       # strip X<...>
1020                 s{>.*}{};
1021                 if (/[\s\'\"]/) { # prose?
1022                 } else {
1023                     s/[^\w:]$//; # period?
1024                     " "x28 . "'$_' => 0,";
1025                 }
1026             } split /\s*,\s*/, $prereq);
1027
1028             if ($name) {
1029                 my $to_file = File::Spec->catfile($build_dir, $name);
1030                 rename $script_file, $to_file
1031                     or die "Can't rename $script_file to $to_file: $!";
1032             }
1033
1034     return "
1035               EXE_FILES => ['$name'],
1036               PREREQ_PM => {
1037 $PREREQ_PM
1038                            },
1039 ";
1040 }
1041
1042 #-> CPAN::Distribution::_signature_business
1043 sub _signature_business {
1044     my($self) = @_;
1045     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
1046                                                       q{check_sigs});
1047     if ($check_sigs) {
1048         if ($CPAN::META->has_inst("Module::Signature")) {
1049             if (-f "SIGNATURE") {
1050                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
1051                 my $rv = Module::Signature::verify();
1052                 if ($rv != Module::Signature::SIGNATURE_OK() and
1053                     $rv != Module::Signature::SIGNATURE_MISSING()) {
1054                     $CPAN::Frontend->mywarn(
1055                                             qq{\nSignature invalid for }.
1056                                             qq{distribution file. }.
1057                                             qq{Please investigate.\n\n}
1058                                            );
1059
1060                     my $wrap =
1061                         sprintf(qq{I'd recommend removing %s. Some error occurred   }.
1062                                 qq{while checking its signature, so it could        }.
1063                                 qq{be invalid. Maybe you have configured            }.
1064                                 qq{your 'urllist' with a bad URL. Please check this }.
1065                                 qq{array with 'o conf urllist' and retry. Or        }.
1066                                 qq{examine the distribution in a subshell. Try
1067   look %s
1068 and run
1069   cpansign -v
1070 },
1071                                 $self->{localfile},
1072                                 $self->pretty_id,
1073                                );
1074                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
1075                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
1076                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
1077                 } else {
1078                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
1079                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
1080                 }
1081             } else {
1082                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
1083             }
1084         } else {
1085             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
1086         }
1087     }
1088 }
1089
1090 #-> CPAN::Distribution::untar_me ;
1091 sub untar_me {
1092     my($self,$ct) = @_;
1093     $self->{archived} = "tar";
1094     my $result = eval { $ct->untar() };
1095     if ($result) {
1096         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
1097     } else {
1098         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
1099     }
1100 }
1101
1102 # CPAN::Distribution::unzip_me ;
1103 sub unzip_me {
1104     my($self,$ct) = @_;
1105     $self->{archived} = "zip";
1106     if ($ct->unzip()) {
1107         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
1108     } else {
1109         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
1110     }
1111     return;
1112 }
1113
1114 sub handle_singlefile {
1115     my($self,$local_file) = @_;
1116
1117     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
1118         $self->{archived} = "pm";
1119     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
1120         $self->{archived} = "patch";
1121     } else {
1122         $self->{archived} = "maybe_pl";
1123     }
1124
1125     my $to = File::Basename::basename($local_file);
1126     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
1127         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
1128             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
1129         } else {
1130             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
1131         }
1132     } else {
1133         if (File::Copy::cp($local_file,".")) {
1134             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
1135         } else {
1136             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
1137         }
1138     }
1139     return $to;
1140 }
1141
1142 #-> sub CPAN::Distribution::new ;
1143 sub new {
1144     my($class,%att) = @_;
1145
1146     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
1147
1148     my $this = { %att };
1149     return bless $this, $class;
1150 }
1151
1152 #-> sub CPAN::Distribution::look ;
1153 sub look {
1154     my($self) = @_;
1155
1156     if ($^O eq 'MacOS') {
1157       $self->Mac::BuildTools::look;
1158       return;
1159     }
1160
1161     if (  $CPAN::Config->{'shell'} ) {
1162         $CPAN::Frontend->myprint(qq{
1163 Trying to open a subshell in the build directory...
1164 });
1165     } else {
1166         $CPAN::Frontend->myprint(qq{
1167 Your configuration does not define a value for subshells.
1168 Please define it with "o conf shell <your shell>"
1169 });
1170         return;
1171     }
1172     my $dist = $self->id;
1173     my $dir;
1174     unless ($dir = $self->dir) {
1175         $self->get;
1176     }
1177     unless ($dir ||= $self->dir) {
1178         $CPAN::Frontend->mywarn(qq{
1179 Could not determine which directory to use for looking at $dist.
1180 });
1181         return;
1182     }
1183     my $pwd  = CPAN::anycwd();
1184     $self->safe_chdir($dir);
1185     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
1186     {
1187         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
1188         $ENV{CPAN_SHELL_LEVEL} += 1;
1189         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
1190
1191         local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
1192             ? $ENV{PERL5LIB}
1193                 : ($ENV{PERLLIB} || "");
1194
1195         local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
1196         $CPAN::META->set_perl5lib;
1197         local $ENV{MAKEFLAGS}; # protect us from outer make calls
1198
1199         unless (system($shell) == 0) {
1200             my $code = $? >> 8;
1201             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
1202         }
1203     }
1204     $self->safe_chdir($pwd);
1205 }
1206
1207 # CPAN::Distribution::cvs_import ;
1208 sub cvs_import {
1209     my($self) = @_;
1210     $self->get;
1211     my $dir = $self->dir;
1212
1213     my $package = $self->called_for;
1214     my $module = $CPAN::META->instance('CPAN::Module', $package);
1215     my $version = $module->cpan_version;
1216
1217     my $userid = $self->cpan_userid;
1218
1219     my $cvs_dir = (split /\//, $dir)[-1];
1220     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
1221     my $cvs_root =
1222       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
1223     my $cvs_site_perl =
1224       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
1225     if ($cvs_site_perl) {
1226         $cvs_dir = "$cvs_site_perl/$cvs_dir";
1227     }
1228     my $cvs_log = qq{"imported $package $version sources"};
1229     $version =~ s/\./_/g;
1230     # XXX cvs: undocumented and unclear how it was meant to work
1231     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
1232                "$cvs_dir", $userid, "v$version");
1233
1234     my $pwd  = CPAN::anycwd();
1235     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
1236
1237     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
1238
1239     $CPAN::Frontend->myprint(qq{@cmd\n});
1240     system(@cmd) == 0 or
1241     # XXX cvs
1242         $CPAN::Frontend->mydie("cvs import failed");
1243     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
1244 }
1245
1246 #-> sub CPAN::Distribution::readme ;
1247 sub readme {
1248     my($self) = @_;
1249     my($dist) = $self->id;
1250     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
1251     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
1252     my($local_file);
1253     my($local_wanted) =
1254         File::Spec->catfile(
1255                             $CPAN::Config->{keep_source_where},
1256                             "authors",
1257                             "id",
1258                             split(/\//,"$sans.readme"),
1259                            );
1260     $self->debug("Doing localize") if $CPAN::DEBUG;
1261     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
1262                                       $local_wanted)
1263         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
1264
1265     if ($^O eq 'MacOS') {
1266         Mac::BuildTools::launch_file($local_file);
1267         return;
1268     }
1269
1270     my $fh_pager = FileHandle->new;
1271     local($SIG{PIPE}) = "IGNORE";
1272     my $pager = $CPAN::Config->{'pager'} || "cat";
1273     $fh_pager->open("|$pager")
1274         or die "Could not open pager $pager\: $!";
1275     my $fh_readme = FileHandle->new;
1276     $fh_readme->open($local_file)
1277         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
1278     $CPAN::Frontend->myprint(qq{
1279 Displaying file
1280   $local_file
1281 with pager "$pager"
1282 });
1283     $fh_pager->print(<$fh_readme>);
1284     $fh_pager->close;
1285 }
1286
1287 #-> sub CPAN::Distribution::verifyCHECKSUM ;
1288 sub verifyCHECKSUM {
1289     my($self) = @_;
1290   EXCUSE: {
1291         my @e;
1292         $self->{CHECKSUM_STATUS} ||= "";
1293         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
1294         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
1295     }
1296     my($lc_want,$lc_file,@local,$basename);
1297     @local = split(/\//,$self->id);
1298     pop @local;
1299     push @local, "CHECKSUMS";
1300     $lc_want =
1301         File::Spec->catfile($CPAN::Config->{keep_source_where},
1302                             "authors", "id", @local);
1303     local($") = "/";
1304     if (my $size = -s $lc_want) {
1305         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
1306         if ($self->CHECKSUM_check_file($lc_want,1)) {
1307             return $self->{CHECKSUM_STATUS} = "OK";
1308         }
1309     }
1310     $lc_file = CPAN::FTP->localize("authors/id/@local",
1311                                    $lc_want,1);
1312     unless ($lc_file) {
1313         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
1314         $local[-1] .= ".gz";
1315         $lc_file = CPAN::FTP->localize("authors/id/@local",
1316                                        "$lc_want.gz",1);
1317         if ($lc_file) {
1318             $lc_file =~ s/\.gz(?!\n)\Z//;
1319             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
1320         } else {
1321             return;
1322         }
1323     }
1324     if ($self->CHECKSUM_check_file($lc_file)) {
1325         return $self->{CHECKSUM_STATUS} = "OK";
1326     }
1327 }
1328
1329 #-> sub CPAN::Distribution::SIG_check_file ;
1330 sub SIG_check_file {
1331     my($self,$chk_file) = @_;
1332     my $rv = eval { Module::Signature::_verify($chk_file) };
1333
1334     if ($rv == Module::Signature::SIGNATURE_OK()) {
1335         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
1336         return $self->{SIG_STATUS} = "OK";
1337     } else {
1338         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
1339                                  qq{distribution file. }.
1340                                  qq{Please investigate.\n\n}.
1341                                  $self->as_string,
1342                                  $CPAN::META->instance(
1343                                                        'CPAN::Author',
1344                                                        $self->cpan_userid
1345                                                       )->as_string);
1346
1347         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
1348 is invalid. Maybe you have configured your 'urllist' with
1349 a bad URL. Please check this array with 'o conf urllist', and
1350 retry.};
1351
1352         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
1353     }
1354 }
1355
1356 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
1357
1358 # sloppy is 1 when we have an old checksums file that maybe is good
1359 # enough
1360
1361 sub CHECKSUM_check_file {
1362     my($self,$chk_file,$sloppy) = @_;
1363     my($cksum,$file,$basename);
1364
1365     $sloppy ||= 0;
1366     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
1367     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
1368                                                       q{check_sigs});
1369     if ($check_sigs) {
1370         if ($CPAN::META->has_inst("Module::Signature")) {
1371             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
1372             $self->SIG_check_file($chk_file);
1373         } else {
1374             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
1375         }
1376     }
1377
1378     $file = $self->{localfile};
1379     $basename = File::Basename::basename($file);
1380     my $fh = FileHandle->new;
1381     if (open $fh, $chk_file) {
1382         local($/);
1383         my $eval = <$fh>;
1384         $eval =~ s/\015?\012/\n/g;
1385         close $fh;
1386         my($compmt) = Safe->new();
1387         $cksum = $compmt->reval($eval);
1388         if ($@) {
1389             rename $chk_file, "$chk_file.bad";
1390             Carp::confess($@) if $@;
1391         }
1392     } else {
1393         Carp::carp "Could not open $chk_file for reading";
1394     }
1395
1396     if (! ref $cksum or ref $cksum ne "HASH") {
1397         $CPAN::Frontend->mywarn(qq{
1398 Warning: checksum file '$chk_file' broken.
1399
1400 When trying to read that file I expected to get a hash reference
1401 for further processing, but got garbage instead.
1402 });
1403         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
1404         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1405         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
1406         return;
1407     } elsif (exists $cksum->{$basename}{sha256}) {
1408         $self->debug("Found checksum for $basename:" .
1409                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
1410
1411         open($fh, $file);
1412         binmode $fh;
1413         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
1414         $fh->close;
1415         $fh = CPAN::Tarzip->TIEHANDLE($file);
1416
1417         unless ($eq) {
1418             my $dg = Digest::SHA->new(256);
1419             my($data,$ref);
1420             $ref = \$data;
1421             while ($fh->READ($ref, 4096) > 0) {
1422                 $dg->add($data);
1423             }
1424             my $hexdigest = $dg->hexdigest;
1425             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
1426         }
1427
1428         if ($eq) {
1429             $CPAN::Frontend->myprint("Checksum for $file ok\n");
1430             return $self->{CHECKSUM_STATUS} = "OK";
1431         } else {
1432             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
1433                                      qq{distribution file. }.
1434                                      qq{Please investigate.\n\n}.
1435                                      $self->as_string,
1436                                      $CPAN::META->instance(
1437                                                            'CPAN::Author',
1438                                                            $self->cpan_userid
1439                                                           )->as_string);
1440
1441             my $wrap = qq{I\'d recommend removing $file. Its
1442 checksum is incorrect. Maybe you have configured your 'urllist' with
1443 a bad URL. Please check this array with 'o conf urllist', and
1444 retry.};
1445
1446             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
1447
1448             # former versions just returned here but this seems a
1449             # serious threat that deserves a die
1450
1451             # $CPAN::Frontend->myprint("\n\n");
1452             # sleep 3;
1453             # return;
1454         }
1455         # close $fh if fileno($fh);
1456     } else {
1457         return if $sloppy;
1458         unless ($self->{CHECKSUM_STATUS}) {
1459             $CPAN::Frontend->mywarn(qq{
1460 Warning: No checksum for $basename in $chk_file.
1461
1462 The cause for this may be that the file is very new and the checksum
1463 has not yet been calculated, but it may also be that something is
1464 going awry right now.
1465 });
1466             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
1467             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1468         }
1469         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
1470         return;
1471     }
1472 }
1473
1474 #-> sub CPAN::Distribution::eq_CHECKSUM ;
1475 sub eq_CHECKSUM {
1476     my($self,$fh,$expect) = @_;
1477     if ($CPAN::META->has_inst("Digest::SHA")) {
1478         my $dg = Digest::SHA->new(256);
1479         my($data);
1480         while (read($fh, $data, 4096)) {
1481             $dg->add($data);
1482         }
1483         my $hexdigest = $dg->hexdigest;
1484         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
1485         return $hexdigest eq $expect;
1486     }
1487     return 1;
1488 }
1489
1490 #-> sub CPAN::Distribution::force ;
1491
1492 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
1493 # effect by autoinspection, not by inspecting a global variable. One
1494 # of the reason why this was chosen to work that way was the treatment
1495 # of dependencies. They should not automatically inherit the force
1496 # status. But this has the downside that ^C and die() will return to
1497 # the prompt but will not be able to reset the force_update
1498 # attributes. We try to correct for it currently in the read_metadata
1499 # routine, and immediately before we check for a Signal. I hope this
1500 # works out in one of v1.57_53ff
1501
1502 # "Force get forgets previous error conditions"
1503
1504 #-> sub CPAN::Distribution::fforce ;
1505 sub fforce {
1506   my($self, $method) = @_;
1507   $self->force($method,1);
1508 }
1509
1510 #-> sub CPAN::Distribution::force ;
1511 sub force {
1512   my($self, $method,$fforce) = @_;
1513   my %phase_map = (
1514                    get => [
1515                            "unwrapped",
1516                            "build_dir",
1517                            "archived",
1518                            "localfile",
1519                            "CHECKSUM_STATUS",
1520                            "signature_verify",
1521                            "prefs",
1522                            "prefs_file",
1523                            "prefs_file_doc",
1524                           ],
1525                    make => [
1526                             "writemakefile",
1527                             "make",
1528                             "modulebuild",
1529                             "prereq_pm",
1530                             "prereq_pm_detected",
1531                            ],
1532                    test => [
1533                             "badtestcnt",
1534                             "make_test",
1535                            ],
1536                    install => [
1537                                "install",
1538                               ],
1539                    unknown => [
1540                                "reqtype",
1541                                "yaml_content",
1542                               ],
1543                   );
1544   my $methodmatch = 0;
1545   my $ldebug = 0;
1546  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
1547       $methodmatch = 1 if $fforce || $phase eq $method;
1548       next unless $methodmatch;
1549     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
1550           if ($phase eq "get") {
1551               if (substr($self->id,-1,1) eq "."
1552                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
1553                   # cannot be undone for local distros
1554                   next ATTRIBUTE;
1555               }
1556               if ($att eq "build_dir"
1557                   && $self->{build_dir}
1558                   && $CPAN::META->{is_tested}
1559                  ) {
1560                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
1561               }
1562           } elsif ($phase eq "test") {
1563               if ($att eq "make_test"
1564                   && $self->{make_test}
1565                   && $self->{make_test}{COMMANDID}
1566                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
1567                  ) {
1568                   # endless loop too likely
1569                   next ATTRIBUTE;
1570               }
1571           }
1572           delete $self->{$att};
1573           if ($ldebug || $CPAN::DEBUG) {
1574               # local $CPAN::DEBUG = 16; # Distribution
1575               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
1576           }
1577       }
1578   }
1579   if ($method && $method =~ /make|test|install/) {
1580     $self->{force_update} = 1; # name should probably have been force_install
1581   }
1582 }
1583
1584 #-> sub CPAN::Distribution::notest ;
1585 sub notest {
1586   my($self, $method) = @_;
1587   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
1588   $self->{"notest"}++; # name should probably have been force_install
1589 }
1590
1591 #-> sub CPAN::Distribution::unnotest ;
1592 sub unnotest {
1593   my($self) = @_;
1594   # warn "XDEBUG: deleting notest";
1595   delete $self->{notest};
1596 }
1597
1598 #-> sub CPAN::Distribution::unforce ;
1599 sub unforce {
1600   my($self) = @_;
1601   delete $self->{force_update};
1602 }
1603
1604 #-> sub CPAN::Distribution::isa_perl ;
1605 sub isa_perl {
1606   my($self) = @_;
1607   my $file = File::Basename::basename($self->id);
1608   if ($file =~ m{ ^ perl
1609                   -?
1610                   (5)
1611                   ([._-])
1612                   (
1613                    \d{3}(_[0-4][0-9])?
1614                    |
1615                    \d+\.\d+
1616                   )
1617                   \.tar[._-](?:gz|bz2)
1618                   (?!\n)\Z
1619                 }xs) {
1620     return "$1.$3";
1621   } elsif ($self->cpan_comment
1622            &&
1623            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
1624     return $1;
1625   }
1626 }
1627
1628
1629 #-> sub CPAN::Distribution::perl ;
1630 sub perl {
1631     my ($self) = @_;
1632     if (! $self) {
1633         use Carp qw(carp);
1634         carp __PACKAGE__ . "::perl was called without parameters.";
1635     }
1636     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
1637 }
1638
1639
1640 #-> sub CPAN::Distribution::make ;
1641 sub make {
1642     my($self) = @_;
1643     if (my $goto = $self->prefs->{goto}) {
1644         return $self->goto($goto);
1645     }
1646     my $make = $self->{modulebuild} ? "Build" : "make";
1647     # Emergency brake if they said install Pippi and get newest perl
1648     if ($self->isa_perl) {
1649         if (
1650             $self->called_for ne $self->id &&
1651             ! $self->{force_update}
1652         ) {
1653             # if we die here, we break bundles
1654             $CPAN::Frontend
1655                 ->mywarn(sprintf(
1656                             qq{The most recent version "%s" of the module "%s"
1657 is part of the perl-%s distribution. To install that, you need to run
1658   force install %s   --or--
1659   install %s
1660 },
1661                              $CPAN::META->instance(
1662                                                    'CPAN::Module',
1663                                                    $self->called_for
1664                                                   )->cpan_version,
1665                              $self->called_for,
1666                              $self->isa_perl,
1667                              $self->called_for,
1668                              $self->id,
1669                             ));
1670             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
1671             $CPAN::Frontend->mysleep(1);
1672             return;
1673         }
1674     }
1675     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
1676     $self->get;
1677     return if $self->prefs->{disabled} && ! $self->{force_update};
1678     if ($self->{configure_requires_later}) {
1679         return;
1680     }
1681     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
1682                            ? $ENV{PERL5LIB}
1683                            : ($ENV{PERLLIB} || "");
1684     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
1685     $CPAN::META->set_perl5lib;
1686     local $ENV{MAKEFLAGS}; # protect us from outer make calls
1687
1688     if ($CPAN::Signal) {
1689         delete $self->{force_update};
1690         return;
1691     }
1692
1693     my $builddir;
1694   EXCUSE: {
1695         my @e;
1696         if (!$self->{archived} || $self->{archived} eq "NO") {
1697             push @e, "Is neither a tar nor a zip archive.";
1698         }
1699
1700         if (!$self->{unwrapped}
1701             || (
1702                 UNIVERSAL::can($self->{unwrapped},"failed") ?
1703                 $self->{unwrapped}->failed :
1704                 $self->{unwrapped} =~ /^NO/
1705                )) {
1706             push @e, "Had problems unarchiving. Please build manually";
1707         }
1708
1709         unless ($self->{force_update}) {
1710             exists $self->{signature_verify} and
1711                 (
1712                  UNIVERSAL::can($self->{signature_verify},"failed") ?
1713                  $self->{signature_verify}->failed :
1714                  $self->{signature_verify} =~ /^NO/
1715                 )
1716                 and push @e, "Did not pass the signature test.";
1717         }
1718
1719         if (exists $self->{writemakefile} &&
1720             (
1721              UNIVERSAL::can($self->{writemakefile},"failed") ?
1722              $self->{writemakefile}->failed :
1723              $self->{writemakefile} =~ /^NO/
1724             )) {
1725             # XXX maybe a retry would be in order?
1726             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
1727                 $self->{writemakefile}->text :
1728                     $self->{writemakefile};
1729             $err =~ s/^NO\s*(--\s+)?//;
1730             $err ||= "Had some problem writing Makefile";
1731             $err .= ", won't make";
1732             push @e, $err;
1733         }
1734
1735         if (defined $self->{make}) {
1736             if (UNIVERSAL::can($self->{make},"failed") ?
1737                 $self->{make}->failed :
1738                 $self->{make} =~ /^NO/) {
1739                 if ($self->{force_update}) {
1740                     # Trying an already failed 'make' (unless somebody else blocks)
1741                 } else {
1742                     # introduced for turning recursion detection into a distrostatus
1743                     my $error = length $self->{make}>3
1744                         ? substr($self->{make},3) : "Unknown error";
1745                     $CPAN::Frontend->mywarn("Could not make: $error\n");
1746                     $self->store_persistent_state;
1747                     return;
1748                 }
1749             } else {
1750                 push @e, "Has already been made";
1751                 my $wait_for_prereqs = eval { $self->satisfy_requires };
1752                 return 1 if $wait_for_prereqs;   # tells queuerunner to continue
1753                 return $self->goodbye($@) if $@; # tells queuerunner to stop
1754             }
1755         }
1756
1757         my $later = $self->{later} || $self->{configure_requires_later};
1758         if ($later) { # see also undelay
1759             if ($later) {
1760                 push @e, $later;
1761             }
1762         }
1763
1764         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
1765         $builddir = $self->dir or
1766             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
1767         unless (chdir $builddir) {
1768             push @e, "Couldn't chdir to '$builddir': $!";
1769         }
1770         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
1771     }
1772     if ($CPAN::Signal) {
1773         delete $self->{force_update};
1774         return;
1775     }
1776     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
1777     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
1778
1779     if ($^O eq 'MacOS') {
1780         Mac::BuildTools::make($self);
1781         return;
1782     }
1783
1784     my %env;
1785     while (my($k,$v) = each %ENV) {
1786         next unless defined $v;
1787         $env{$k} = $v;
1788     }
1789     local %ENV = %env;
1790     my $system;
1791     my $pl_commandline;
1792     if ($self->prefs->{pl}) {
1793         $pl_commandline = $self->prefs->{pl}{commandline};
1794     }
1795     if ($pl_commandline) {
1796         $system = $pl_commandline;
1797         $ENV{PERL} = $^X;
1798     } elsif ($self->{'configure'}) {
1799         $system = $self->{'configure'};
1800     } elsif ($self->{modulebuild}) {
1801         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
1802         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
1803     } else {
1804         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
1805         my $switch = "";
1806 # This needs a handler that can be turned on or off:
1807 #        $switch = "-MExtUtils::MakeMaker ".
1808 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
1809 #            if $] > 5.00310;
1810         my $makepl_arg = $self->_make_phase_arg("pl");
1811         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
1812                                                             "Makefile.PL");
1813         $system = sprintf("%s%s Makefile.PL%s",
1814                           $perl,
1815                           $switch ? " $switch" : "",
1816                           $makepl_arg ? " $makepl_arg" : "",
1817                          );
1818     }
1819     my $pl_env;
1820     if ($self->prefs->{pl}) {
1821         $pl_env = $self->prefs->{pl}{env};
1822     }
1823     if ($pl_env) {
1824         for my $e (keys %$pl_env) {
1825             $ENV{$e} = $pl_env->{$e};
1826         }
1827     }
1828     if (exists $self->{writemakefile}) {
1829     } else {
1830         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
1831         my($ret,$pid,$output);
1832         $@ = "";
1833         my $go_via_alarm;
1834         if ($CPAN::Config->{inactivity_timeout}) {
1835             require Config;
1836             if ($Config::Config{d_alarm}
1837                 &&
1838                 $Config::Config{d_alarm} eq "define"
1839                ) {
1840                 $go_via_alarm++
1841             } else {
1842                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
1843                                         "variable 'inactivity_timeout' to ".
1844                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
1845                                         "on this machine the system call 'alarm' ".
1846                                         "isn't available. This means that we cannot ".
1847                                         "provide the feature of intercepting long ".
1848                                         "waiting code and will turn this feature off.\n"
1849                                        );
1850                 $CPAN::Config->{inactivity_timeout} = 0;
1851             }
1852         }
1853         if ($go_via_alarm) {
1854             if ( $self->_should_report('pl') ) {
1855                 ($output, $ret) = CPAN::Reporter::record_command(
1856                     $system,
1857                     $CPAN::Config->{inactivity_timeout},
1858                 );
1859                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
1860             }
1861             else {
1862                 eval {
1863                     alarm $CPAN::Config->{inactivity_timeout};
1864                     local $SIG{CHLD}; # = sub { wait };
1865                     if (defined($pid = fork)) {
1866                         if ($pid) { #parent
1867                             # wait;
1868                             waitpid $pid, 0;
1869                         } else {    #child
1870                             # note, this exec isn't necessary if
1871                             # inactivity_timeout is 0. On the Mac I'd
1872                             # suggest, we set it always to 0.
1873                             exec $system;
1874                         }
1875                     } else {
1876                         $CPAN::Frontend->myprint("Cannot fork: $!");
1877                         return;
1878                     }
1879                 };
1880                 alarm 0;
1881                 if ($@) {
1882                     kill 9, $pid;
1883                     waitpid $pid, 0;
1884                     my $err = "$@";
1885                     $CPAN::Frontend->myprint($err);
1886                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
1887                     $@ = "";
1888                     $self->store_persistent_state;
1889                     return $self->goodbye("$system -- TIMED OUT");
1890                 }
1891             }
1892         } else {
1893             if (my $expect_model = $self->_prefs_with_expect("pl")) {
1894                 # XXX probably want to check _should_report here and warn
1895                 # about not being able to use CPAN::Reporter with expect
1896                 $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
1897                 if (! defined $ret
1898                     && $self->{writemakefile}
1899                     && $self->{writemakefile}->failed) {
1900                     # timeout
1901                     return;
1902                 }
1903             }
1904             elsif ( $self->_should_report('pl') ) {
1905                 ($output, $ret) = CPAN::Reporter::record_command($system);
1906                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
1907             }
1908             else {
1909                 $ret = system($system);
1910             }
1911             if ($ret != 0) {
1912                 $self->{writemakefile} = CPAN::Distrostatus
1913                     ->new("NO '$system' returned status $ret");
1914                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
1915                 $self->store_persistent_state;
1916                 return $self->goodbye("$system -- NOT OK");
1917             }
1918         }
1919         if (-f "Makefile" || -f "Build") {
1920             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
1921             delete $self->{make_clean}; # if cleaned before, enable next
1922         } else {
1923             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
1924             my $why = "No '$makefile' created";
1925             $CPAN::Frontend->mywarn($why);
1926             $self->{writemakefile} = CPAN::Distrostatus
1927                 ->new(qq{NO -- $why\n});
1928             $self->store_persistent_state;
1929             return $self->goodbye("$system -- NOT OK");
1930         }
1931     }
1932     if ($CPAN::Signal) {
1933         delete $self->{force_update};
1934         return;
1935     }
1936     my $wait_for_prereqs = eval { $self->satisfy_requires };
1937     return 1 if $wait_for_prereqs;   # tells queuerunner to continue
1938     return $self->goodbye($@) if $@; # tells queuerunner to stop
1939     if ($CPAN::Signal) {
1940         delete $self->{force_update};
1941         return;
1942     }
1943     my $make_commandline;
1944     if ($self->prefs->{make}) {
1945         $make_commandline = $self->prefs->{make}{commandline};
1946     }
1947     if ($make_commandline) {
1948         $system = $make_commandline;
1949         $ENV{PERL} = CPAN::find_perl();
1950     } else {
1951         if ($self->{modulebuild}) {
1952             unless (-f "Build") {
1953                 my $cwd = CPAN::anycwd();
1954                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
1955                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
1956                 $CPAN::Frontend->mysleep(5);
1957             }
1958             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
1959         } else {
1960             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
1961         }
1962         $system =~ s/\s+$//;
1963         my $make_arg = $self->_make_phase_arg("make");
1964         $system = sprintf("%s%s",
1965                           $system,
1966                           $make_arg ? " $make_arg" : "",
1967                          );
1968     }
1969     my $make_env;
1970     if ($self->prefs->{make}) {
1971         $make_env = $self->prefs->{make}{env};
1972     }
1973     if ($make_env) { # overriding the local ENV of PL, not the outer
1974                      # ENV, but unlikely to be a risk
1975         for my $e (keys %$make_env) {
1976             $ENV{$e} = $make_env->{$e};
1977         }
1978     }
1979     my $expect_model = $self->_prefs_with_expect("make");
1980     my $want_expect = 0;
1981     if ( $expect_model && @{$expect_model->{talk}} ) {
1982         my $can_expect = $CPAN::META->has_inst("Expect");
1983         if ($can_expect) {
1984             $want_expect = 1;
1985         } else {
1986             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
1987                                     "system()\n");
1988         }
1989     }
1990     my $system_ok;
1991     if ($want_expect) {
1992         # XXX probably want to check _should_report here and
1993         # warn about not being able to use CPAN::Reporter with expect
1994         $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
1995     }
1996     elsif ( $self->_should_report('make') ) {
1997         my ($output, $ret) = CPAN::Reporter::record_command($system);
1998         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
1999         $system_ok = ! $ret;
2000     }
2001     else {
2002         $system_ok = system($system) == 0;
2003     }
2004     $self->introduce_myself;
2005     if ( $system_ok ) {
2006         $CPAN::Frontend->myprint("  $system -- OK\n");
2007         $self->{make} = CPAN::Distrostatus->new("YES");
2008     } else {
2009         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
2010         $self->{make} = CPAN::Distrostatus->new("NO");
2011         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
2012     }
2013     $self->store_persistent_state;
2014 }
2015
2016 # CPAN::Distribution::goodbye ;
2017 sub goodbye {
2018     my($self,$goodbye) = @_;
2019     my $id = $self->pretty_id;
2020     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
2021     return;
2022 }
2023
2024 # CPAN::Distribution::_run_via_expect ;
2025 sub _run_via_expect {
2026     my($self,$system,$phase,$expect_model) = @_;
2027     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
2028     if ($CPAN::META->has_inst("Expect")) {
2029         my $expo = Expect->new;  # expo Expect object;
2030         $expo->spawn($system);
2031         $expect_model->{mode} ||= "deterministic";
2032         if ($expect_model->{mode} eq "deterministic") {
2033             return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
2034         } elsif ($expect_model->{mode} eq "anyorder") {
2035             return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
2036         } else {
2037             die "Panic: Illegal expect mode: $expect_model->{mode}";
2038         }
2039     } else {
2040         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
2041         return system($system);
2042     }
2043 }
2044
2045 sub _run_via_expect_anyorder {
2046     my($self,$expo,$phase,$expect_model) = @_;
2047     my $timeout = $expect_model->{timeout} || 5;
2048     my $reuse = $expect_model->{reuse};
2049     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
2050     my $but = "";
2051     my $timeout_start = time;
2052   EXPECT: while () {
2053         my($eof,$ran_into_timeout);
2054         # XXX not up to the full power of expect. one could certainly
2055         # wrap all of the talk pairs into a single expect call and on
2056         # success tweak it and step ahead to the next question. The
2057         # current implementation unnecessarily limits itself to a
2058         # single match.
2059         my @match = $expo->expect(1,
2060                                   [ eof => sub {
2061                                         $eof++;
2062                                     } ],
2063                                   [ timeout => sub {
2064                                         $ran_into_timeout++;
2065                                     } ],
2066                                   -re => eval"qr{.}",
2067                                  );
2068         if ($match[2]) {
2069             $but .= $match[2];
2070         }
2071         $but .= $expo->clear_accum;
2072         if ($eof) {
2073             $expo->soft_close;
2074             return $expo->exitstatus();
2075         } elsif ($ran_into_timeout) {
2076             # warn "DEBUG: they are asking a question, but[$but]";
2077             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
2078                 my($next,$send) = @expectacopy[$i,$i+1];
2079                 my $regex = eval "qr{$next}";
2080                 # warn "DEBUG: will compare with regex[$regex].";
2081                 if ($but =~ /$regex/) {
2082                     # warn "DEBUG: will send send[$send]";
2083                     $expo->send($send);
2084                     # never allow reusing an QA pair unless they told us
2085                     splice @expectacopy, $i, 2 unless $reuse;
2086                     next EXPECT;
2087                 }
2088             }
2089             my $have_waited = time - $timeout_start;
2090             if ($have_waited < $timeout) {
2091                 # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
2092                 next EXPECT;
2093             }
2094             my $why = "could not answer a question during the dialog";
2095             $CPAN::Frontend->mywarn("Failing: $why\n");
2096             $self->{$phase} =
2097                 CPAN::Distrostatus->new("NO $why");
2098             return 0;
2099         }
2100     }
2101 }
2102
2103 sub _run_via_expect_deterministic {
2104     my($self,$expo,$phase,$expect_model) = @_;
2105     my $ran_into_timeout;
2106     my $ran_into_eof;
2107     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
2108     my $expecta = $expect_model->{talk};
2109   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
2110         my($re,$send) = @$expecta[$i,$i+1];
2111         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
2112         my $regex = eval "qr{$re}";
2113         $expo->expect($timeout,
2114                       [ eof => sub {
2115                             my $but = $expo->clear_accum;
2116                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
2117 expected[$regex]\nbut[$but]\n\n");
2118                             $ran_into_eof++;
2119                         } ],
2120                       [ timeout => sub {
2121                             my $but = $expo->clear_accum;
2122                             $CPAN::Frontend->mywarn("TIMEOUT
2123 expected[$regex]\nbut[$but]\n\n");
2124                             $ran_into_timeout++;
2125                         } ],
2126                       -re => $regex);
2127         if ($ran_into_timeout) {
2128             # note that the caller expects 0 for success
2129             $self->{$phase} =
2130                 CPAN::Distrostatus->new("NO timeout during expect dialog");
2131             return 0;
2132         } elsif ($ran_into_eof) {
2133             last EXPECT;
2134         }
2135         $expo->send($send);
2136     }
2137     $expo->soft_close;
2138     return $expo->exitstatus();
2139 }
2140
2141 #-> CPAN::Distribution::_validate_distropref
2142 sub _validate_distropref {
2143     my($self,@args) = @_;
2144     if (
2145         $CPAN::META->has_inst("CPAN::Kwalify")
2146         &&
2147         $CPAN::META->has_inst("Kwalify")
2148        ) {
2149         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
2150         if ($@) {
2151             $CPAN::Frontend->mywarn($@);
2152         }
2153     } else {
2154         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
2155     }
2156 }
2157
2158 #-> CPAN::Distribution::_find_prefs
2159 sub _find_prefs {
2160     my($self) = @_;
2161     my $distroid = $self->pretty_id;
2162     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
2163     my $prefs_dir = $CPAN::Config->{prefs_dir};
2164     return if $prefs_dir =~ /^\s*$/;
2165     eval { File::Path::mkpath($prefs_dir); };
2166     if ($@) {
2167         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
2168     }
2169     my $yaml_module = CPAN::_yaml_module();
2170     my $ext_map = {};
2171     my @extensions;
2172     if ($CPAN::META->has_inst($yaml_module)) {
2173         $ext_map->{yml} = 'CPAN';
2174     } else {
2175         my @fallbacks;
2176         if ($CPAN::META->has_inst("Data::Dumper")) {
2177             push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
2178         }
2179         if ($CPAN::META->has_inst("Storable")) {
2180             push @fallbacks, $ext_map->{st} = 'Storable';
2181         }
2182         if (@fallbacks) {
2183             local $" = " and ";
2184             unless ($self->{have_complained_about_missing_yaml}++) {
2185                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
2186                                         "to @fallbacks to read prefs '$prefs_dir'\n");
2187             }
2188         } else {
2189             unless ($self->{have_complained_about_missing_yaml}++) {
2190                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
2191                                         "read prefs '$prefs_dir'\n");
2192             }
2193         }
2194     }
2195     my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
2196     DIRENT: while (my $result = $finder->next) {
2197         if ($result->is_warning) {
2198             $CPAN::Frontend->mywarn($result->as_string);
2199             $CPAN::Frontend->mysleep(1);
2200             next DIRENT;
2201         } elsif ($result->is_fatal) {
2202             $CPAN::Frontend->mydie($result->as_string);
2203         }
2204
2205         my @prefs = @{ $result->prefs };
2206
2207       ELEMENT: for my $y (0..$#prefs) {
2208             my $pref = $prefs[$y];
2209             $self->_validate_distropref($pref->data, $result->abs, $y);
2210
2211             # I don't know why we silently skip when there's no match, but
2212             # complain if there's an empty match hashref, and there's no
2213             # comment explaining why -- hdp, 2008-03-18
2214             unless ($pref->has_any_match) {
2215                 next ELEMENT;
2216             }
2217
2218             unless ($pref->has_valid_subkeys) {
2219                 $CPAN::Frontend->mydie(sprintf
2220                     "Nonconforming .%s file '%s': " .
2221                     "missing match/* subattribute. " .
2222                     "Please remove, cannot continue.",
2223                     $result->ext, $result->abs,
2224                 );
2225             }
2226
2227             my $arg = {
2228                 env          => \%ENV,
2229                 distribution => $distroid,
2230                 perl         => \&CPAN::find_perl,
2231                 perlconfig   => \%Config::Config,
2232                 module       => sub { [ $self->containsmods ] },
2233             };
2234
2235             if ($pref->matches($arg)) {
2236                 return {
2237                     prefs => $pref->data,
2238                     prefs_file => $result->abs,
2239                     prefs_file_doc => $y,
2240                 };
2241             }
2242
2243         }
2244     }
2245     return;
2246 }
2247
2248 # CPAN::Distribution::prefs
2249 sub prefs {
2250     my($self) = @_;
2251     if (exists $self->{negative_prefs_cache}
2252         &&
2253         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
2254        ) {
2255         delete $self->{negative_prefs_cache};
2256         delete $self->{prefs};
2257     }
2258     if (exists $self->{prefs}) {
2259         return $self->{prefs}; # XXX comment out during debugging
2260     }
2261     if ($CPAN::Config->{prefs_dir}) {
2262         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
2263         my $prefs = $self->_find_prefs();
2264         $prefs ||= ""; # avoid warning next line
2265         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
2266         if ($prefs) {
2267             for my $x (qw(prefs prefs_file prefs_file_doc)) {
2268                 $self->{$x} = $prefs->{$x};
2269             }
2270             my $bs = sprintf(
2271                              "%s[%s]",
2272                              File::Basename::basename($self->{prefs_file}),
2273                              $self->{prefs_file_doc},
2274                             );
2275             my $filler1 = "_" x 22;
2276             my $filler2 = int(66 - length($bs))/2;
2277             $filler2 = 0 if $filler2 < 0;
2278             $filler2 = " " x $filler2;
2279             $CPAN::Frontend->myprint("
2280 $filler1 D i s t r o P r e f s $filler1
2281 $filler2 $bs $filler2
2282 ");
2283             $CPAN::Frontend->mysleep(1);
2284             return $self->{prefs};
2285         }
2286     }
2287     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
2288     return $self->{prefs} = +{};
2289 }
2290
2291 # CPAN::Distribution::_make_phase_arg
2292 sub _make_phase_arg {
2293     my($self, $phase) = @_;
2294     my $_make_phase_arg;
2295     my $prefs = $self->prefs;
2296     if (
2297         $prefs
2298         && exists $prefs->{$phase}
2299         && exists $prefs->{$phase}{args}
2300         && $prefs->{$phase}{args}
2301        ) {
2302         $_make_phase_arg = join(" ",
2303                            map {CPAN::HandleConfig
2304                                  ->safe_quote($_)} @{$prefs->{$phase}{args}},
2305                           );
2306     }
2307
2308 # cpan[2]> o conf make[TAB]
2309 # make                       make_install_make_command
2310 # make_arg                   makepl_arg
2311 # make_install_arg
2312 # cpan[2]> o conf mbuild[TAB]
2313 # mbuild_arg                    mbuild_install_build_command
2314 # mbuild_install_arg            mbuildpl_arg
2315
2316     my $mantra; # must switch make/mbuild here
2317     if ($self->{modulebuild}) {
2318         $mantra = "mbuild";
2319     } else {
2320         $mantra = "make";
2321     }
2322     my %map = (
2323                pl => "pl_arg",
2324                make => "_arg",
2325                test => "_test_arg", # does not really exist but maybe
2326                                     # will some day and now protects
2327                                     # us from unini warnings
2328                install => "_install_arg",
2329               );
2330     my $phase_underscore_meshup = $map{$phase};
2331     my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
2332
2333     $_make_phase_arg ||= $CPAN::Config->{$what};
2334     return $_make_phase_arg;
2335 }
2336
2337 # CPAN::Distribution::_make_command
2338 sub _make_command {
2339     my ($self) = @_;
2340     if ($self) {
2341         return
2342             CPAN::HandleConfig
2343                 ->safe_quote(
2344                              CPAN::HandleConfig->prefs_lookup($self,
2345                                                               q{make})
2346                              || $Config::Config{make}
2347                              || 'make'
2348                             );
2349     } else {
2350         # Old style call, without object. Deprecated
2351         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
2352         return
2353           safe_quote(undef,
2354                      CPAN::HandleConfig->prefs_lookup($self,q{make})
2355                      || $CPAN::Config->{make}
2356                      || $Config::Config{make}
2357                      || 'make');
2358     }
2359 }
2360
2361 #-> sub CPAN::Distribution::follow_prereqs ;
2362 sub follow_prereqs {
2363     my($self) = shift;
2364     my($slot) = shift;
2365     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
2366     return unless @prereq_tuples;
2367     my(@good_prereq_tuples);
2368     for my $p (@prereq_tuples) {
2369         # XXX watch out for foul ones
2370         push @good_prereq_tuples, $p;
2371     }
2372     my $pretty_id = $self->pretty_id;
2373     my %map = (
2374                b => "build_requires",
2375                r => "requires",
2376                c => "commandline",
2377               );
2378     my($filler1,$filler2,$filler3,$filler4);
2379     my $unsat = "Unsatisfied dependencies detected during";
2380     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
2381     {
2382         my $r = int(($w - length($unsat))/2);
2383         my $l = $w - length($unsat) - $r;
2384         $filler1 = "-"x4 . " "x$l;
2385         $filler2 = " "x$r . "-"x4 . "\n";
2386     }
2387     {
2388         my $r = int(($w - length($pretty_id))/2);
2389         my $l = $w - length($pretty_id) - $r;
2390         $filler3 = "-"x4 . " "x$l;
2391         $filler4 = " "x$r . "-"x4 . "\n";
2392     }
2393     $CPAN::Frontend->
2394         myprint("$filler1 $unsat $filler2".
2395                 "$filler3 $pretty_id $filler4".
2396                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
2397                );
2398     my $follow = 0;
2399     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
2400         $follow = 1;
2401     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
2402         my $answer = CPAN::Shell::colorable_makemaker_prompt(
2403 "Shall I follow them and prepend them to the queue
2404 of modules we are processing right now?", "yes");
2405         $follow = $answer =~ /^\s*y/i;
2406     } else {
2407         my @prereq = map { $_=>[0] } @good_prereq_tuples;
2408         local($") = ", ";
2409         $CPAN::Frontend->
2410             myprint("  Ignoring dependencies on modules @prereq\n");
2411     }
2412     if ($follow) {
2413         my $id = $self->id;
2414         # color them as dirty
2415         for my $gp (@good_prereq_tuples) {
2416             # warn "calling color_cmd_tmps(0,1)";
2417             my $p = $gp->[0];
2418             my $any = CPAN::Shell->expandany($p);
2419             $self->{$slot . "_for"}{$any->id}++;
2420             if ($any) {
2421                 $any->color_cmd_tmps(0,2);
2422             } else {
2423                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
2424                 $CPAN::Frontend->mysleep(2);
2425             }
2426         }
2427         # queue them and re-queue yourself
2428         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
2429                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
2430         $self->{$slot} = "Delayed until after prerequisites";
2431         return 1; # signal success to the queuerunner
2432     }
2433     return;
2434 }
2435
2436 sub _feature_depends {
2437     my($self) = @_;
2438     my $meta_yml = $self->parse_meta_yml();
2439     my $optf = $meta_yml->{optional_features} or return;
2440     if (!ref $optf or ref $optf ne "HASH"){
2441         $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
2442         $optf = {};
2443     }
2444     my $wantf = $self->prefs->{features} or return;
2445     if (!ref $wantf or ref $wantf ne "ARRAY"){
2446         $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
2447         $wantf = [];
2448     }
2449     my $dep = +{};
2450     for my $wf (@$wantf) {
2451         if (my $f = $optf->{$wf}) {
2452             $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
2453                                      "is accompanied by this description:\n".
2454                                      $f->{description}.
2455                                      "\n\n"
2456                                     );
2457             # configure_requires currently not in the spec, unlikely to be useful anyway
2458             for my $reqtype (qw(configure_requires build_requires requires)) {
2459                 my $reqhash = $f->{$reqtype} or next;
2460                 while (my($k,$v) = each %$reqhash) {
2461                     $dep->{$reqtype}{$k} = $v;
2462                 }
2463             }
2464         } else {
2465             $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
2466                                     "found in the META.yml file".
2467                                     "\n\n"
2468                                    );
2469         }
2470     }
2471     $dep;
2472 }
2473
2474 #-> sub CPAN::Distribution::unsat_prereq ;
2475 # return ([Foo,"r"],[Bar,"b"]) for normal modules
2476 # return ([perl=>5.008]) if we need a newer perl than we are running under
2477 # (sorry for the inconsistency, it was an accident)
2478 sub unsat_prereq {
2479     my($self,$slot) = @_;
2480     my(%merged,$prereq_pm);
2481     my $prefs_depends = $self->prefs->{depends}||{};
2482     my $feature_depends = $self->_feature_depends();
2483     if ($slot eq "configure_requires_later") {
2484         my $meta_yml = $self->parse_meta_yml();
2485         if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
2486             $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
2487             $meta_yml = +{};
2488         }
2489         %merged = (
2490                    %{$meta_yml->{configure_requires}||{}},
2491                    %{$prefs_depends->{configure_requires}||{}},
2492                    %{$feature_depends->{configure_requires}||{}},
2493                   );
2494         $prereq_pm = {}; # configure_requires defined as "b"
2495     } elsif ($slot eq "later") {
2496         my $prereq_pm_0 = $self->prereq_pm || {};
2497         for my $reqtype (qw(requires build_requires)) {
2498             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
2499             for my $dep ($prefs_depends,$feature_depends) {
2500                 for my $k (keys %{$dep->{$reqtype}||{}}) {
2501                     $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
2502                 }
2503             }
2504         }
2505         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
2506     } else {
2507         die "Panic: illegal slot '$slot'";
2508     }
2509     my(@need);
2510     my @merged = %merged;
2511     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
2512   NEED: while (my($need_module, $need_version) = each %merged) {
2513         my($available_version,$available_file,$nmo);
2514         if ($need_module eq "perl") {
2515             $available_version = $];
2516             $available_file = CPAN::find_perl();
2517         } else {
2518             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
2519             next if $nmo->uptodate;
2520             $available_file = $nmo->available_file;
2521
2522             # if they have not specified a version, we accept any installed one
2523             if (defined $available_file
2524                 and ( # a few quick shortcurcuits
2525                      not defined $need_version
2526                      or $need_version eq '0'    # "==" would trigger warning when not numeric
2527                      or $need_version eq "undef"
2528                     )) {
2529                 next NEED;
2530             }
2531
2532             $available_version = $nmo->available_version;
2533         }
2534
2535         # We only want to install prereqs if either they're not installed
2536         # or if the installed version is too old. We cannot omit this
2537         # check, because if 'force' is in effect, nobody else will check.
2538         if (defined $available_file) {
2539             my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
2540                 ($need_module,$available_file,$available_version,$need_version);
2541             next NEED if $fulfills_all_version_rqs;
2542         }
2543
2544         if ($need_module eq "perl") {
2545             return ["perl", $need_version];
2546         }
2547         $self->{sponsored_mods}{$need_module} ||= 0;
2548         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
2549         if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
2550             # We have already sponsored it and for some reason it's still
2551             # not available. So we do ... what??
2552
2553             # if we push it again, we have a potential infinite loop
2554
2555             # The following "next" was a very problematic construct.
2556             # It helped a lot but broke some day and had to be
2557             # replaced.
2558
2559             # We must be able to deal with modules that come again and
2560             # again as a prereq and have themselves prereqs and the
2561             # queue becomes long but finally we would find the correct
2562             # order. The RecursiveDependency check should trigger a
2563             # die when it's becoming too weird. Unfortunately removing
2564             # this next breaks many other things.
2565
2566             # The bug that brought this up is described in Todo under
2567             # "5.8.9 cannot install Compress::Zlib"
2568
2569             # next; # this is the next that had to go away
2570
2571             # The following "next NEED" are fine and the error message
2572             # explains well what is going on. For example when the DBI
2573             # fails and consequently DBD::SQLite fails and now we are
2574             # processing CPAN::SQLite. Then we must have a "next" for
2575             # DBD::SQLite. How can we get it and how can we identify
2576             # all other cases we must identify?
2577
2578             my $do = $nmo->distribution;
2579             next NEED unless $do; # not on CPAN
2580             if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
2581                 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
2582                                         "'$need_module => $need_version' ".
2583                                         "for '$self->{ID}' seems ".
2584                                         "not available according to the indices\n"
2585                                        );
2586                 next NEED;
2587             }
2588           NOSAYER: for my $nosayer (
2589                                     "unwrapped",
2590                                     "writemakefile",
2591                                     "signature_verify",
2592                                     "make",
2593                                     "make_test",
2594                                     "install",
2595                                     "make_clean",
2596                                    ) {
2597                 if ($do->{$nosayer}) {
2598                     my $selfid = $self->pretty_id;
2599                     my $did = $do->pretty_id;
2600                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
2601                         $do->{$nosayer}->failed :
2602                         $do->{$nosayer} =~ /^NO/) {
2603                         if ($nosayer eq "make_test"
2604                             &&
2605                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
2606                            ) {
2607                             next NOSAYER;
2608                         }
2609                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
2610                                                 "'$need_module => $need_version' ".
2611                                                 "for '$selfid' failed when ".
2612                                                 "processing '$did' with ".
2613                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
2614                                                 "but chances to succeed are limited.\n"
2615                                                );
2616                         $CPAN::Frontend->mysleep($sponsoring/10);
2617                         next NEED;
2618                     } else { # the other guy succeeded
2619                         if ($nosayer =~ /^(install|make_test)$/) {
2620                             # we had this with
2621                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
2622                             # in 2007-03 for 'make install'
2623                             # and 2008-04: #30464 (for 'make test')
2624                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
2625                                                     "'$need_module => $need_version' ".
2626                                                     "for '$selfid' already built ".
2627                                                     "but the result looks suspicious. ".
2628                                                     "Skipping another build attempt, ".
2629                                                     "to prevent looping endlessly.\n"
2630                                                    );
2631                             next NEED;
2632                         }
2633                     }
2634                 }
2635             }
2636         }
2637         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
2638         push @need, [$need_module,$needed_as];
2639     }
2640     my @unfolded = map { "[".join(",",@$_)."]" } @need;
2641     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
2642     @need;
2643 }
2644
2645 sub _fulfills_all_version_rqs {
2646     my($self,$need_module,$available_file,$available_version,$need_version) = @_;
2647     my(@all_requirements) = split /\s*,\s*/, $need_version;
2648     local($^W) = 0;
2649     my $ok = 0;
2650   RQ: for my $rq (@all_requirements) {
2651         if ($rq =~ s|>=\s*||) {
2652         } elsif ($rq =~ s|>\s*||) {
2653             # 2005-12: one user
2654             if (CPAN::Version->vgt($available_version,$rq)) {
2655                 $ok++;
2656             }
2657             next RQ;
2658         } elsif ($rq =~ s|!=\s*||) {
2659             # 2005-12: no user
2660             if (CPAN::Version->vcmp($available_version,$rq)) {
2661                 $ok++;
2662                 next RQ;
2663             } else {
2664                 last RQ;
2665             }
2666         } elsif ($rq =~ m|<=?\s*|) {
2667             # 2005-12: no user
2668             $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
2669             $ok++;
2670             next RQ;
2671         }
2672         if (! CPAN::Version->vgt($rq, $available_version)) {
2673             $ok++;
2674         }
2675         CPAN->debug(sprintf("need_module[%s]available_file[%s]".
2676                             "available_version[%s]rq[%s]ok[%d]",
2677                             $need_module,
2678                             $available_file,
2679                             $available_version,
2680                             CPAN::Version->readable($rq),
2681                             $ok,
2682                            )) if $CPAN::DEBUG;
2683     }
2684     return $ok == @all_requirements;
2685 }
2686
2687 #-> sub CPAN::Distribution::read_yaml ;
2688 sub read_yaml {
2689     my($self) = @_;
2690     return $self->{yaml_content} if exists $self->{yaml_content};
2691     my $build_dir;
2692     unless ($build_dir = $self->{build_dir}) {
2693         # maybe permission on build_dir was missing
2694         $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
2695         return;
2696     }
2697     my $yaml = File::Spec->catfile($build_dir,"META.yml");
2698     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
2699     return unless -f $yaml;
2700     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
2701     if ($@) {
2702         $CPAN::Frontend->mywarn("Could not read ".
2703                                 "'$yaml'. Falling back to other ".
2704                                 "methods to determine prerequisites\n");
2705         return $self->{yaml_content} = undef; # if we die, then we
2706                                               # cannot read YAML's own
2707                                               # META.yml
2708     }
2709     # not "authoritative"
2710     for ($self->{yaml_content}) {
2711         if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
2712             $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
2713             $self->{yaml_content} = +{};
2714         }
2715     }
2716     if (not exists $self->{yaml_content}{dynamic_config}
2717         or $self->{yaml_content}{dynamic_config}
2718        ) {
2719         $self->{yaml_content} = undef;
2720     }
2721     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
2722         if $CPAN::DEBUG;
2723     return $self->{yaml_content};
2724 }
2725
2726 #-> sub CPAN::Distribution::prereq_pm ;
2727 sub prereq_pm {
2728     my($self) = @_;
2729     $self->{prereq_pm_detected} ||= 0;
2730     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
2731     return $self->{prereq_pm} if $self->{prereq_pm_detected};
2732     return unless $self->{writemakefile}  # no need to have succeeded
2733                                           # but we must have run it
2734         || $self->{modulebuild};
2735     unless ($self->{build_dir}) {
2736         return;
2737     }
2738     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
2739                 $self->{writemakefile}||"",
2740                 $self->{modulebuild}||"",
2741                ) if $CPAN::DEBUG;
2742     my($req,$breq);
2743     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
2744         $req =  $yaml->{requires} || {};
2745         $breq =  $yaml->{build_requires} || {};
2746         undef $req unless ref $req eq "HASH" && %$req;
2747         if ($req) {
2748             if ($yaml->{generated_by} &&
2749                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
2750                 my $eummv = do { local $^W = 0; $1+0; };
2751                 if ($eummv < 6.2501) {
2752                     # thanks to Slaven for digging that out: MM before
2753                     # that could be wrong because it could reflect a
2754                     # previous release
2755                     undef $req;
2756                 }
2757             }
2758             my $areq;
2759             my $do_replace;
2760             while (my($k,$v) = each %{$req||{}}) {
2761                 if ($v =~ /\d/) {
2762                     $areq->{$k} = $v;
2763                 } elsif ($k =~ /[A-Za-z]/ &&
2764                          $v =~ /[A-Za-z]/ &&
2765                          $CPAN::META->exists("CPAN::Module",$v)
2766                         ) {
2767                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
2768                                             "requires hash: $k => $v; I'll take both ".
2769                                             "key and value as a module name\n");
2770                     $CPAN::Frontend->mysleep(1);
2771                     $areq->{$k} = 0;
2772                     $areq->{$v} = 0;
2773                     $do_replace++;
2774                 }
2775             }
2776             $req = $areq if $do_replace;
2777         }
2778     }
2779     unless ($req || $breq) {
2780         my $build_dir;
2781         unless ( $build_dir = $self->{build_dir} ) {
2782             return;
2783         }
2784         my $makefile = File::Spec->catfile($build_dir,"Makefile");
2785         my $fh;
2786         if (-f $makefile
2787             and
2788             $fh = FileHandle->new("<$makefile\0")) {
2789             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
2790             local($/) = "\n";
2791             while (<$fh>) {
2792                 last if /MakeMaker post_initialize section/;
2793                 my($p) = m{^[\#]
2794                            \s+PREREQ_PM\s+=>\s+(.+)
2795                        }x;
2796                 next unless $p;
2797                 # warn "Found prereq expr[$p]";
2798
2799                 #  Regexp modified by A.Speer to remember actual version of file
2800                 #  PREREQ_PM hash key wants, then add to
2801                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
2802                     # In case a prereq is mentioned twice, complain.
2803                     if ( defined $req->{$1} ) {
2804                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
2805                             "last mention wins";
2806                     }
2807                     my($m,$n) = ($1,$2);
2808                     if ($n =~ /^q\[(.*?)\]$/) {
2809                         $n = $1;
2810                     }
2811                     $req->{$m} = $n;
2812                 }
2813                 last;
2814             }
2815         }
2816     }
2817     unless ($req || $breq) {
2818         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
2819         my $buildfile = File::Spec->catfile($build_dir,"Build");
2820         if (-f $buildfile) {
2821             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
2822             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
2823             if (-f $build_prereqs) {
2824                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
2825                 my $content = do { local *FH;
2826                                    open FH, $build_prereqs
2827                                        or $CPAN::Frontend->mydie("Could not open ".
2828                                                                  "'$build_prereqs': $!");
2829                                    local $/;
2830                                    <FH>;
2831                                };
2832                 my $bphash = eval $content;
2833                 if ($@) {
2834                 } else {
2835                     $req  = $bphash->{requires} || +{};
2836                     $breq = $bphash->{build_requires} || +{};
2837                 }
2838             }
2839         }
2840     }
2841     if (-f "Build.PL"
2842         && ! -f "Makefile.PL"
2843         && ! exists $req->{"Module::Build"}
2844         && ! $CPAN::META->has_inst("Module::Build")) {
2845         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
2846                                 "undeclared prerequisite.\n".
2847                                 "  Adding it now as such.\n"
2848                                );
2849         $CPAN::Frontend->mysleep(5);
2850         $req->{"Module::Build"} = 0;
2851         delete $self->{writemakefile};
2852     }
2853     if ($req || $breq) {
2854         $self->{prereq_pm_detected}++;
2855         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
2856     }
2857 }
2858
2859 #-> sub CPAN::Distribution::test ;
2860 sub test {
2861     my($self) = @_;
2862     if (my $goto = $self->prefs->{goto}) {
2863         return $self->goto($goto);
2864     }
2865     $self->make;
2866     return if $self->prefs->{disabled} && ! $self->{force_update};
2867     if ($CPAN::Signal) {
2868       delete $self->{force_update};
2869       return;
2870     }
2871     # warn "XDEBUG: checking for notest: $self->{notest} $self";
2872     if ($self->{notest}) {
2873         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
2874         return 1;
2875     }
2876
2877     my $make = $self->{modulebuild} ? "Build" : "make";
2878
2879     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
2880                            ? $ENV{PERL5LIB}
2881                            : ($ENV{PERLLIB} || "");
2882
2883     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
2884     $CPAN::META->set_perl5lib;
2885     local $ENV{MAKEFLAGS}; # protect us from outer make calls
2886
2887     $CPAN::Frontend->myprint("Running $make test\n");
2888
2889   EXCUSE: {
2890         my @e;
2891         if ($self->{make} or $self->{later}) {
2892             # go ahead
2893         } else {
2894             push @e,
2895                 "Make had some problems, won't test";
2896         }
2897
2898         exists $self->{make} and
2899             (
2900              UNIVERSAL::can($self->{make},"failed") ?
2901              $self->{make}->failed :
2902              $self->{make} =~ /^NO/
2903             ) and push @e, "Can't test without successful make";
2904         $self->{badtestcnt} ||= 0;
2905         if ($self->{badtestcnt} > 0) {
2906             require Data::Dumper;
2907             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
2908             push @e, "Won't repeat unsuccessful test during this command";
2909         }
2910
2911         push @e, $self->{later} if $self->{later};
2912         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
2913
2914         if (exists $self->{build_dir}) {
2915             if (exists $self->{make_test}) {
2916                 if (
2917                     UNIVERSAL::can($self->{make_test},"failed") ?
2918                     $self->{make_test}->failed :
2919                     $self->{make_test} =~ /^NO/
2920                    ) {
2921                     if (
2922                         UNIVERSAL::can($self->{make_test},"commandid")
2923                         &&
2924                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
2925                        ) {
2926                         push @e, "Has already been tested within this command";
2927                     }
2928                 } else {
2929                     push @e, "Has already been tested successfully";
2930                     # if global "is_tested" has been cleared, we need to mark this to
2931                     # be added to PERL5LIB if not already installed
2932                     if ($self->tested_ok_but_not_installed) {
2933                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
2934                     }
2935                 }
2936             }
2937         } elsif (!@e) {
2938             push @e, "Has no own directory";
2939         }
2940         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
2941         unless (chdir $self->{build_dir}) {
2942             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
2943         }
2944         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
2945     }
2946     $self->debug("Changed directory to $self->{build_dir}")
2947         if $CPAN::DEBUG;
2948
2949     if ($^O eq 'MacOS') {
2950         Mac::BuildTools::make_test($self);
2951         return;
2952     }
2953
2954     if ($self->{modulebuild}) {
2955         my $thm = CPAN::Shell->expand("Module","Test::Harness");
2956         my $v = $thm->inst_version;
2957         if (CPAN::Version->vlt($v,2.62)) {
2958             # XXX Eric Wilhelm reported this as a bug: klapperl:
2959             # Test::Harness 3.0 self-tests, so that should be 'unless
2960             # installing Test::Harness'
2961             unless ($self->id eq $thm->distribution->id) {
2962                $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
2963   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
2964                 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
2965                 return;
2966             }
2967         }
2968     }
2969
2970     if ( ! $self->{force_update}  ) {
2971         # bypass actual tests if "trust_test_report_history" and have a report
2972         my $have_tested_fcn;
2973         if (   $CPAN::Config->{trust_test_report_history}
2974             && $CPAN::META->has_inst("CPAN::Reporter::History")
2975             && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
2976             if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
2977                 # Do nothing if grade was DISCARD
2978                 if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
2979                     $self->{make_test} = CPAN::Distrostatus->new("YES");
2980                     # if global "is_tested" has been cleared, we need to mark this to
2981                     # be added to PERL5LIB if not already installed
2982                     if ($self->tested_ok_but_not_installed) {
2983                         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
2984                     }
2985                     $CPAN::Frontend->myprint("Found prior test report -- OK\n");
2986                     return;
2987                 }
2988                 elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
2989                     $self->{make_test} = CPAN::Distrostatus->new("NO");
2990                     $self->{badtestcnt}++;
2991                     $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
2992                     return;
2993                 }
2994             }
2995         }
2996     }
2997
2998     my $system;
2999     my $prefs_test = $self->prefs->{test};
3000     if (my $commandline
3001         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
3002         $system = $commandline;
3003         $ENV{PERL} = CPAN::find_perl();
3004     } elsif ($self->{modulebuild}) {
3005         $system = sprintf "%s test", $self->_build_command();
3006         unless (-e "Build") {
3007             my $id = $self->pretty_id;
3008             $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
3009         }
3010     } else {
3011         $system = join " ", $self->_make_command(), "test";
3012     }
3013     my $make_test_arg = $self->_make_phase_arg("test");
3014     $system = sprintf("%s%s",
3015                       $system,
3016                       $make_test_arg ? " $make_test_arg" : "",
3017                      );
3018     my($tests_ok);
3019     my %env;
3020     while (my($k,$v) = each %ENV) {
3021         next unless defined $v;
3022         $env{$k} = $v;
3023     }
3024     local %ENV = %env;
3025     my $test_env;
3026     if ($self->prefs->{test}) {
3027         $test_env = $self->prefs->{test}{env};
3028     }
3029     if ($test_env) {
3030         for my $e (keys %$test_env) {
3031             $ENV{$e} = $test_env->{$e};
3032         }
3033     }
3034     my $expect_model = $self->_prefs_with_expect("test");
3035     my $want_expect = 0;
3036     if ( $expect_model && @{$expect_model->{talk}} ) {
3037         my $can_expect = $CPAN::META->has_inst("Expect");
3038         if ($can_expect) {
3039             $want_expect = 1;
3040         } else {
3041             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
3042                                     "testing without\n");
3043         }
3044     }
3045     if ($want_expect) {
3046         if ($self->_should_report('test')) {
3047             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
3048                                     "not supported when distroprefs specify ".
3049                                     "an interactive test\n");
3050         }
3051         $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
3052     } elsif ( $self->_should_report('test') ) {
3053         $tests_ok = CPAN::Reporter::test($self, $system);
3054     } else {
3055         $tests_ok = system($system) == 0;
3056     }
3057     $self->introduce_myself;
3058     if ( $tests_ok ) {
3059         {
3060             my @prereq;
3061
3062             # local $CPAN::DEBUG = 16; # Distribution
3063             for my $m (keys %{$self->{sponsored_mods}}) {
3064                 next unless $self->{sponsored_mods}{$m} > 0;
3065                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
3066                 # XXX we need available_version which reflects
3067                 # $ENV{PERL5LIB} so that already tested but not yet
3068                 # installed modules are counted.
3069                 my $available_version = $m_obj->available_version;
3070                 my $available_file = $m_obj->available_file;
3071                 if ($available_version &&
3072                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
3073                    ) {
3074                     CPAN->debug("m[$m] good enough available_version[$available_version]")
3075                         if $CPAN::DEBUG;
3076                 } elsif ($available_file
3077                          && (
3078                              !$self->{prereq_pm}{$m}
3079                              ||
3080                              $self->{prereq_pm}{$m} == 0
3081                             )
3082                         ) {
3083                     # lex Class::Accessor::Chained::Fast which has no $VERSION
3084                     CPAN->debug("m[$m] have available_file[$available_file]")
3085                         if $CPAN::DEBUG;
3086                 } else {
3087                     push @prereq, $m;
3088                 }
3089             }
3090             if (@prereq) {
3091                 my $cnt = @prereq;
3092                 my $which = join ",", @prereq;
3093                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
3094                     "$cnt dependencies missing ($which)";
3095                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
3096                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
3097                 $self->store_persistent_state;
3098                 return $self->goodbye("[dependencies] -- NA");
3099             }
3100         }
3101
3102         $CPAN::Frontend->myprint("  $system -- OK\n");
3103         $self->{make_test} = CPAN::Distrostatus->new("YES");
3104         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
3105         # probably impossible to need the next line because badtestcnt
3106         # has a lifespan of one command
3107         delete $self->{badtestcnt};
3108     } else {
3109         $self->{make_test} = CPAN::Distrostatus->new("NO");
3110         $self->{badtestcnt}++;
3111         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
3112         CPAN::Shell->optprint
3113               ("hint",
3114                sprintf
3115                ("//hint// to see the cpan-testers results for installing this module, try:
3116   reports %s\n",
3117                 $self->pretty_id));
3118     }
3119     $self->store_persistent_state;
3120 }
3121
3122 sub _prefs_with_expect {
3123     my($self,$where) = @_;
3124     return unless my $prefs = $self->prefs;
3125     return unless my $where_prefs = $prefs->{$where};
3126     if ($where_prefs->{expect}) {
3127         return {
3128                 mode => "deterministic",
3129                 timeout => 15,
3130                 talk => $where_prefs->{expect},
3131                };
3132     } elsif ($where_prefs->{"eexpect"}) {
3133         return $where_prefs->{"eexpect"};
3134     }
3135     return;
3136 }
3137
3138 #-> sub CPAN::Distribution::clean ;
3139 sub clean {
3140     my($self) = @_;
3141     my $make = $self->{modulebuild} ? "Build" : "make";
3142     $CPAN::Frontend->myprint("Running $make clean\n");
3143     unless (exists $self->{archived}) {
3144         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
3145                                 "/untarred, nothing done\n");
3146         return 1;
3147     }
3148     unless (exists $self->{build_dir}) {
3149         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
3150         return 1;
3151     }
3152     if (exists $self->{writemakefile}
3153         and $self->{writemakefile}->failed
3154        ) {
3155         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
3156         return 1;
3157     }
3158   EXCUSE: {
3159         my @e;
3160         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
3161             push @e, "make clean already called once";
3162         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3163     }
3164     chdir $self->{build_dir} or
3165         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
3166     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
3167
3168     if ($^O eq 'MacOS') {
3169         Mac::BuildTools::make_clean($self);
3170         return;
3171     }
3172
3173     my $system;
3174     if ($self->{modulebuild}) {
3175         unless (-f "Build") {
3176             my $cwd = CPAN::anycwd();
3177             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
3178                                     " in cwd[$cwd]. Danger, Will Robinson!");
3179             $CPAN::Frontend->mysleep(5);
3180         }
3181         $system = sprintf "%s clean", $self->_build_command();
3182     } else {
3183         $system  = join " ", $self->_make_command(), "clean";
3184     }
3185     my $system_ok = system($system) == 0;
3186     $self->introduce_myself;
3187     if ( $system_ok ) {
3188       $CPAN::Frontend->myprint("  $system -- OK\n");
3189
3190       # $self->force;
3191
3192       # Jost Krieger pointed out that this "force" was wrong because
3193       # it has the effect that the next "install" on this distribution
3194       # will untar everything again. Instead we should bring the
3195       # object's state back to where it is after untarring.
3196
3197       for my $k (qw(
3198                     force_update
3199                     install
3200                     writemakefile
3201                     make
3202                     make_test
3203                    )) {
3204           delete $self->{$k};
3205       }
3206       $self->{make_clean} = CPAN::Distrostatus->new("YES");
3207
3208     } else {
3209       # Hmmm, what to do if make clean failed?
3210
3211       $self->{make_clean} = CPAN::Distrostatus->new("NO");
3212       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
3213
3214       # 2006-02-27: seems silly to me to force a make now
3215       # $self->force("make"); # so that this directory won't be used again
3216
3217     }
3218     $self->store_persistent_state;
3219 }
3220
3221 #-> sub CPAN::Distribution::goto ;
3222 sub goto {
3223     my($self,$goto) = @_;
3224     $goto = $self->normalize($goto);
3225     my $why = sprintf(
3226                       "Goto '$goto' via prefs file '%s' doc %d",
3227                       $self->{prefs_file},
3228                       $self->{prefs_file_doc},
3229                      );
3230     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
3231     # 2007-07-16 akoenig : Better than NA would be if we could inherit
3232     # the status of the $goto distro but given the exceptional nature
3233     # of 'goto' I feel reluctant to implement it
3234     my $goodbye_message = "[goto] -- NA $why";
3235     $self->goodbye($goodbye_message);
3236
3237     # inject into the queue
3238
3239     CPAN::Queue->delete($self->id);
3240     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
3241
3242     # and run where we left off
3243
3244     my($method) = (caller(1))[3];
3245     CPAN->instance("CPAN::Distribution",$goto)->$method();
3246     CPAN::Queue->delete_first($goto);
3247 }
3248
3249 #-> sub CPAN::Distribution::install ;
3250 sub install {
3251     my($self) = @_;
3252     if (my $goto = $self->prefs->{goto}) {
3253         return $self->goto($goto);
3254     }
3255     unless ($self->{badtestcnt}) {
3256         $self->test;
3257     }
3258     if ($CPAN::Signal) {
3259       delete $self->{force_update};
3260       return;
3261     }
3262     my $make = $self->{modulebuild} ? "Build" : "make";
3263     $CPAN::Frontend->myprint("Running $make install\n");
3264   EXCUSE: {
3265         my @e;
3266         if ($self->{make} or $self->{later}) {
3267             # go ahead
3268         } else {
3269             push @e,
3270                 "Make had some problems, won't install";
3271         }
3272
3273         exists $self->{make} and
3274             (
3275              UNIVERSAL::can($self->{make},"failed") ?
3276              $self->{make}->failed :
3277              $self->{make} =~ /^NO/
3278             ) and
3279             push @e, "Make had returned bad status, install seems impossible";
3280
3281         if (exists $self->{build_dir}) {
3282         } elsif (!@e) {
3283             push @e, "Has no own directory";
3284         }
3285
3286         if (exists $self->{make_test} and
3287             (
3288              UNIVERSAL::can($self->{make_test},"failed") ?
3289              $self->{make_test}->failed :
3290              $self->{make_test} =~ /^NO/
3291             )) {
3292             if ($self->{force_update}) {
3293                 $self->{make_test}->text("FAILED but failure ignored because ".
3294                                          "'force' in effect");
3295             } else {
3296                 push @e, "make test had returned bad status, ".
3297                     "won't install without force"
3298             }
3299         }
3300         if (exists $self->{install}) {
3301             if (UNIVERSAL::can($self->{install},"text") ?
3302                 $self->{install}->text eq "YES" :
3303                 $self->{install} =~ /^YES/
3304                ) {
3305                 $CPAN::Frontend->myprint("  Already done\n");
3306                 $CPAN::META->is_installed($self->{build_dir});
3307                 return 1;
3308             } else {
3309                 # comment in Todo on 2006-02-11; maybe retry?
3310                 push @e, "Already tried without success";
3311             }
3312         }
3313
3314         push @e, $self->{later} if $self->{later};
3315         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
3316
3317         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3318         unless (chdir $self->{build_dir}) {
3319             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
3320         }
3321         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
3322     }
3323     $self->debug("Changed directory to $self->{build_dir}")
3324         if $CPAN::DEBUG;
3325
3326     if ($^O eq 'MacOS') {
3327         Mac::BuildTools::make_install($self);
3328         return;
3329     }
3330
3331     my $system;
3332     if (my $commandline = $self->prefs->{install}{commandline}) {
3333         $system = $commandline;
3334         $ENV{PERL} = CPAN::find_perl();
3335     } elsif ($self->{modulebuild}) {
3336         my($mbuild_install_build_command) =
3337             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
3338                 $CPAN::Config->{mbuild_install_build_command} ?
3339                     $CPAN::Config->{mbuild_install_build_command} :
3340                         $self->_build_command();
3341         $system = sprintf("%s install %s",
3342                           $mbuild_install_build_command,
3343                           $CPAN::Config->{mbuild_install_arg},
3344                          );
3345     } else {
3346         my($make_install_make_command) =
3347             CPAN::HandleConfig->prefs_lookup($self,
3348                                              q{make_install_make_command})
3349                   || $self->_make_command();
3350         $system = sprintf("%s install %s",
3351                           $make_install_make_command,
3352                           $CPAN::Config->{make_install_arg},
3353                          );
3354     }
3355
3356     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
3357     my $brip = CPAN::HandleConfig->prefs_lookup($self,
3358                                                 q{build_requires_install_policy});
3359     $brip ||="ask/yes";
3360     my $id = $self->id;
3361     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
3362     my $want_install = "yes";
3363     if ($reqtype eq "b") {
3364         if ($brip eq "no") {
3365             $want_install = "no";
3366         } elsif ($brip =~ m|^ask/(.+)|) {
3367             my $default = $1;
3368             $default = "yes" unless $default =~ /^(y|n)/i;
3369             $want_install =
3370                 CPAN::Shell::colorable_makemaker_prompt
3371                       ("$id is just needed temporarily during building or testing. ".
3372                        "Do you want to install it permanently? (Y/n)",
3373                        $default);
3374         }
3375     }
3376     unless ($want_install =~ /^y/i) {
3377         my $is_only = "is only 'build_requires'";
3378         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
3379         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
3380         delete $self->{force_update};
3381         return;
3382     }
3383     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
3384                            ? $ENV{PERL5LIB}
3385                            : ($ENV{PERLLIB} || "");
3386
3387     local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
3388     $CPAN::META->set_perl5lib;
3389     my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
3390 ("Can't execute $system: $!");
3391     my($makeout) = "";
3392     while (<$pipe>) {
3393         print $_; # intentionally NOT use Frontend->myprint because it
3394                   # looks irritating when we markup in color what we
3395                   # just pass through from an external program
3396         $makeout .= $_;
3397     }
3398     $pipe->close;
3399     my $close_ok = $? == 0;
3400     $self->introduce_myself;
3401     if ( $close_ok ) {
3402         $CPAN::Frontend->myprint("  $system -- OK\n");
3403         $CPAN::META->is_installed($self->{build_dir});
3404         $self->{install} = CPAN::Distrostatus->new("YES");
3405     } else {
3406         $self->{install} = CPAN::Distrostatus->new("NO");
3407         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
3408         my $mimc =
3409             CPAN::HandleConfig->prefs_lookup($self,
3410                                              q{make_install_make_command});
3411         if (
3412             $makeout =~ /permission/s
3413             && $> > 0
3414             && (
3415                 ! $mimc
3416                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
3417                                                               q{make}))
3418                )
3419            ) {
3420             $CPAN::Frontend->myprint(
3421                                      qq{----\n}.
3422                                      qq{  You may have to su }.
3423                                      qq{to root to install the package\n}.
3424                                      qq{  (Or you may want to run something like\n}.
3425                                      qq{    o conf make_install_make_command 'sudo make'\n}.
3426                                      qq{  to raise your permissions.}
3427                                     );
3428         }
3429     }
3430     delete $self->{force_update};
3431     $self->store_persistent_state;
3432 }
3433
3434 sub introduce_myself {
3435     my($self) = @_;
3436     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
3437 }
3438
3439 #-> sub CPAN::Distribution::dir ;
3440 sub dir {
3441     shift->{build_dir};
3442 }
3443
3444 #-> sub CPAN::Distribution::perldoc ;
3445 sub perldoc {
3446     my($self) = @_;
3447
3448     my($dist) = $self->id;
3449     my $package = $self->called_for;
3450
3451     if ($CPAN::META->has_inst("Pod::Perldocs")) {
3452         my($perl) = $self->perl
3453             or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
3454         my @args = ($perl, q{-MPod::Perldocs}, q{-e},
3455                     q{Pod::Perldocs->run()}, $package);
3456         my($wstatus);
3457         unless ( ($wstatus = system(@args)) == 0 ) {
3458             my $estatus = $wstatus >> 8;
3459             $CPAN::Frontend->myprint(qq{
3460     Function system("@args")
3461     returned status $estatus (wstat $wstatus)
3462     });
3463         }
3464     }
3465     else {
3466         $self->_display_url( $CPAN::Defaultdocs . $package );
3467     }
3468 }
3469
3470 #-> sub CPAN::Distribution::_check_binary ;
3471 sub _check_binary {
3472     my ($dist,$shell,$binary) = @_;
3473     my ($pid,$out);
3474
3475     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
3476       if $CPAN::DEBUG;
3477
3478     if ($CPAN::META->has_inst("File::Which")) {
3479         return File::Which::which($binary);
3480     } else {
3481         local *README;
3482         $pid = open README, "which $binary|"
3483             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
3484         return unless $pid;
3485         while (<README>) {
3486             $out .= $_;
3487         }
3488         close README
3489             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
3490                 and return;
3491     }
3492
3493     $CPAN::Frontend->myprint(qq{   + $out \n})
3494       if $CPAN::DEBUG && $out;
3495
3496     return $out;
3497 }
3498
3499 #-> sub CPAN::Distribution::_display_url ;
3500 sub _display_url {
3501     my($self,$url) = @_;
3502     my($res,$saved_file,$pid,$out);
3503
3504     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
3505       if $CPAN::DEBUG;
3506
3507     # should we define it in the config instead?
3508     my $html_converter = "html2text.pl";
3509
3510     my $web_browser = $CPAN::Config->{'lynx'} || undef;
3511     my $web_browser_out = $web_browser
3512         ? CPAN::Distribution->_check_binary($self,$web_browser)
3513         : undef;
3514
3515     if ($web_browser_out) {
3516         # web browser found, run the action
3517         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
3518         $CPAN::Frontend->myprint(qq{system[$browser $url]})
3519             if $CPAN::DEBUG;
3520         $CPAN::Frontend->myprint(qq{
3521 Displaying URL
3522   $url
3523 with browser $browser
3524 });
3525         $CPAN::Frontend->mysleep(1);
3526         system("$browser $url");
3527         if ($saved_file) { 1 while unlink($saved_file) }
3528     } else {
3529         # web browser not found, let's try text only
3530         my $html_converter_out =
3531             CPAN::Distribution->_check_binary($self,$html_converter);
3532         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
3533
3534         if ($html_converter_out ) {
3535             # html2text found, run it
3536             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
3537             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
3538                 unless defined($saved_file);
3539
3540             local *README;
3541             $pid = open README, "$html_converter $saved_file |"
3542                 or $CPAN::Frontend->mydie(qq{
3543 Could not fork '$html_converter $saved_file': $!});
3544             my($fh,$filename);
3545             if ($CPAN::META->has_usable("File::Temp")) {
3546                 $fh = File::Temp->new(
3547                                       dir      => File::Spec->tmpdir,
3548                                       template => 'cpan_htmlconvert_XXXX',
3549                                       suffix => '.txt',
3550                                       unlink => 0,
3551                                      );
3552                 $filename = $fh->filename;
3553             } else {
3554                 $filename = "cpan_htmlconvert_$$.txt";
3555                 $fh = FileHandle->new();
3556                 open $fh, ">$filename" or die;
3557             }
3558             while (<README>) {
3559                 $fh->print($_);
3560             }
3561             close README or
3562                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
3563             my $tmpin = $fh->filename;
3564             $CPAN::Frontend->myprint(sprintf(qq{
3565 Run '%s %s' and
3566 saved output to %s\n},
3567                                              $html_converter,
3568                                              $saved_file,
3569                                              $tmpin,
3570                                             )) if $CPAN::DEBUG;
3571             close $fh;
3572             local *FH;
3573             open FH, $tmpin
3574                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
3575             my $fh_pager = FileHandle->new;
3576             local($SIG{PIPE}) = "IGNORE";
3577             my $pager = $CPAN::Config->{'pager'} || "cat";
3578             $fh_pager->open("|$pager")
3579                 or $CPAN::Frontend->mydie(qq{
3580 Could not open pager '$pager': $!});
3581             $CPAN::Frontend->myprint(qq{
3582 Displaying URL
3583   $url
3584 with pager "$pager"
3585 });
3586             $CPAN::Frontend->mysleep(1);
3587             $fh_pager->print(<FH>);
3588             $fh_pager->close;
3589         } else {
3590             # coldn't find the web browser or html converter
3591             $CPAN::Frontend->myprint(qq{
3592 You need to install lynx or $html_converter to use this feature.});
3593         }
3594     }
3595 }
3596
3597 #-> sub CPAN::Distribution::_getsave_url ;
3598 sub _getsave_url {
3599     my($dist, $shell, $url) = @_;
3600
3601     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
3602       if $CPAN::DEBUG;
3603
3604     my($fh,$filename);
3605     if ($CPAN::META->has_usable("File::Temp")) {
3606         $fh = File::Temp->new(
3607                               dir      => File::Spec->tmpdir,
3608                               template => "cpan_getsave_url_XXXX",
3609                               suffix => ".html",
3610                               unlink => 0,
3611                              );
3612         $filename = $fh->filename;
3613     } else {
3614         $fh = FileHandle->new;
3615         $filename = "cpan_getsave_url_$$.html";
3616     }
3617     my $tmpin = $filename;
3618     if ($CPAN::META->has_usable('LWP')) {
3619         $CPAN::Frontend->myprint("Fetching with LWP:
3620   $url
3621 ");
3622         my $Ua;
3623         CPAN::LWP::UserAgent->config;
3624         eval { $Ua = CPAN::LWP::UserAgent->new; };
3625         if ($@) {
3626             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
3627             return;
3628         } else {
3629             my($var);
3630             $Ua->proxy('http', $var)
3631                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3632             $Ua->no_proxy($var)
3633                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3634         }
3635
3636         my $req = HTTP::Request->new(GET => $url);
3637         $req->header('Accept' => 'text/html');
3638         my $res = $Ua->request($req);
3639         if ($res->is_success) {
3640             $CPAN::Frontend->myprint(" + request successful.\n")
3641                 if $CPAN::DEBUG;
3642             print $fh $res->content;
3643             close $fh;
3644             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
3645                 if $CPAN::DEBUG;
3646             return $tmpin;
3647         } else {
3648             $CPAN::Frontend->myprint(sprintf(
3649                                              "LWP failed with code[%s], message[%s]\n",
3650                                              $res->code,
3651                                              $res->message,
3652                                             ));
3653             return;
3654         }
3655     } else {
3656         $CPAN::Frontend->mywarn("  LWP not available\n");
3657         return;
3658     }
3659 }
3660
3661 #-> sub CPAN::Distribution::_build_command
3662 sub _build_command {
3663     my($self) = @_;
3664     if ($^O eq "MSWin32") { # special code needed at least up to
3665                             # Module::Build 0.2611 and 0.2706; a fix
3666                             # in M:B has been promised 2006-01-30
3667         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
3668         return "$perl ./Build";
3669     }
3670     return "./Build";
3671 }
3672
3673 #-> sub CPAN::Distribution::_should_report
3674 sub _should_report {
3675     my($self, $phase) = @_;
3676     die "_should_report() requires a 'phase' argument"
3677         if ! defined $phase;
3678
3679     # configured
3680     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
3681                                                        q{test_report});
3682     return unless $test_report;
3683
3684     # don't repeat if we cached a result
3685     return $self->{should_report}
3686         if exists $self->{should_report};
3687
3688     # don't report if we generated a Makefile.PL
3689     if ( $self->{had_no_makefile_pl} ) {
3690         $CPAN::Frontend->mywarn(
3691             "Will not send CPAN Testers report with generated Makefile.PL.\n"
3692         );
3693         return $self->{should_report} = 0;
3694     }
3695
3696     # available
3697     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
3698         $CPAN::Frontend->mywarn(
3699             "CPAN::Reporter not installed.  No reports will be sent.\n"
3700         );
3701         return $self->{should_report} = 0;
3702     }
3703
3704     # capable
3705     my $crv = CPAN::Reporter->VERSION;
3706     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
3707         # don't cache $self->{should_report} -- need to check each phase
3708         if ( $phase eq 'test' ) {
3709             return 1;
3710         }
3711         else {
3712             $CPAN::Frontend->mywarn(
3713                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
3714                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
3715             );
3716             return;
3717         }
3718     }
3719
3720     # appropriate
3721     if ($self->is_dot_dist) {
3722         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
3723                                 "for local directories\n");
3724         return $self->{should_report} = 0;
3725     }
3726     if ($self->prefs->{patches}
3727         &&
3728         @{$self->prefs->{patches}}
3729         &&
3730         $self->{patched}
3731        ) {
3732         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
3733                                 "when the source has been patched\n");
3734         return $self->{should_report} = 0;
3735     }
3736
3737     # proceed and cache success
3738     return $self->{should_report} = 1;
3739 }
3740
3741 #-> sub CPAN::Distribution::reports
3742 sub reports {
3743     my($self) = @_;
3744     my $pathname = $self->id;
3745     $CPAN::Frontend->myprint("Distribution: $pathname\n");
3746
3747     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
3748         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
3749     }
3750     unless ($CPAN::META->has_usable("LWP")) {
3751         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3752     }
3753     unless ($CPAN::META->has_usable("File::Temp")) {
3754         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
3755     }
3756
3757     my $d = CPAN::DistnameInfo->new($pathname);
3758
3759     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
3760     my $version   = $d->version;   # "0.02"
3761     my $maturity  = $d->maturity;  # "released"
3762     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
3763     my $cpanid    = $d->cpanid;    # "GBARR"
3764     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
3765
3766     my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist;
3767
3768     CPAN::LWP::UserAgent->config;
3769     my $Ua;
3770     eval { $Ua = CPAN::LWP::UserAgent->new; };
3771     if ($@) {
3772         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3773     }
3774     $CPAN::Frontend->myprint("Fetching '$url'...");
3775     my $resp = $Ua->get($url);
3776     unless ($resp->is_success) {
3777         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3778     }
3779     $CPAN::Frontend->myprint("DONE\n\n");
3780     my $yaml = $resp->content;
3781     # was fuer ein Umweg!
3782     my $fh = File::Temp->new(
3783                              dir      => File::Spec->tmpdir,
3784                              template => 'cpan_reports_XXXX',
3785                              suffix => '.yaml',
3786                              unlink => 0,
3787                             );
3788     my $tfilename = $fh->filename;
3789     print $fh $yaml;
3790     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
3791     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
3792     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
3793     my %other_versions;
3794     my $this_version_seen;
3795     for my $rep (@$unserialized) {
3796         my $rversion = $rep->{version};
3797         if ($rversion eq $version) {
3798             unless ($this_version_seen++) {
3799                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
3800             }
3801             $CPAN::Frontend->myprint
3802                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
3803                          $rep->{archname} eq $Config::Config{archname}?"*":"",
3804                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
3805                          $rep->{action},
3806                          $rep->{perl},
3807                          ucfirst $rep->{osname},
3808                          $rep->{osvers},
3809                          $rep->{archname},
3810                         ));
3811         } else {
3812             $other_versions{$rep->{version}}++;
3813         }
3814     }
3815     unless ($this_version_seen) {
3816         $CPAN::Frontend->myprint("No reports found for version '$version'
3817 Reports for other versions:\n");
3818         for my $v (sort keys %other_versions) {
3819             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
3820         }
3821     }
3822     $url =~ s/\.yaml/.html/;
3823     $CPAN::Frontend->myprint("See $url for details\n");
3824 }
3825
3826 1;