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