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