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