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