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