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