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.34";
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        my @stat = stat $lc_want;
1449        my $epoch_starting_support_of_cpan_path = 1637471530;
1450        if ($stat[9] >= $epoch_starting_support_of_cpan_path) {
1451            if ($self->CHECKSUM_check_file($lc_want, 1)) {
1452                return $self->{CHECKSUM_STATUS} = "OK";
1453            }
1454        } else {
1455            unlink $lc_want;
1456        }
1457    }
1458    $lc_file = CPAN::FTP->localize("authors/id/@local",
1459                                   $lc_want,1);
1460    unless ($lc_file) {
1461        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
1462        $local[-1] .= ".gz";
1463        $lc_file = CPAN::FTP->localize("authors/id/@local",
1464                                       "$lc_want.gz",1);
1465        if ($lc_file) {
1466            $lc_file =~ s/\.gz(?!\n)\Z//;
1467            eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
1468        } else {
1469            return;
1470        }
1471    }
1472    if ($self->CHECKSUM_check_file($lc_file)) {
1473        return $self->{CHECKSUM_STATUS} = "OK";
1474    }
1475}
1476
1477#-> sub CPAN::Distribution::SIG_check_file ;
1478sub SIG_check_file {
1479    my($self,$chk_file) = @_;
1480    my $rv = eval { Module::Signature::_verify($chk_file) };
1481
1482    if ($rv eq Module::Signature::CANNOT_VERIFY()) {
1483        $CPAN::Frontend->myprint(qq{\nSignature for }.
1484                                 qq{file $chk_file could not be verified for an unknown reason. }.
1485                                 $self->as_string.
1486                                 qq{Module::Signature verification returned value $rv\n\n}
1487                                );
1488
1489        my $wrap = qq{The manual says for this case: Cannot verify the
1490OpenPGP signature, maybe due to the lack of a network connection to
1491the key server, or if neither gnupg nor Crypt::OpenPGP exists on the
1492system. You probably want to analyse the situation and if you cannot
1493fix it you will have to decide whether you want to stop this session
1494or you want to turn off signature verification. The latter would be
1495done with the command 'o conf init check_sigs'};
1496
1497        $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
1498    } if ($rv == Module::Signature::SIGNATURE_OK()) {
1499        $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
1500        return $self->{SIG_STATUS} = "OK";
1501    } else {
1502        $CPAN::Frontend->mywarn(qq{\nSignature invalid for }.
1503                                 qq{file $chk_file. }.
1504                                 qq{Please investigate.\n\n}.
1505                                 $self->as_string.
1506                                 qq{Module::Signature verification returned value $rv\n\n}
1507                                );
1508
1509        my $wrap = qq{I\'d recommend removing $chk_file. Its signature
1510is invalid. Maybe you have configured your 'urllist' with
1511a bad URL. Please check this array with 'o conf urllist', and
1512retry.};
1513
1514        $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
1515    }
1516}
1517
1518#-> sub CPAN::Distribution::CHECKSUM_check_file ;
1519
1520# sloppy is 1 when we have an old checksums file that maybe is good
1521# enough
1522
1523sub CHECKSUM_check_file {
1524    my($self,$chk_file,$sloppy) = @_;
1525    my($cksum,$file,$basename);
1526
1527    $sloppy ||= 0;
1528    $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
1529    my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
1530                                                      q{check_sigs});
1531    if ($check_sigs) {
1532        if ($CPAN::META->has_inst("Module::Signature")) {
1533            $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
1534            $self->SIG_check_file($chk_file);
1535        } else {
1536            $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
1537        }
1538    }
1539
1540    $file = $self->{localfile};
1541    $basename = File::Basename::basename($file);
1542    my($signed_data);
1543    my $fh = FileHandle->new;
1544    if ($check_sigs) {
1545        my $tempdir;
1546        if ($CPAN::META->has_usable("File::Temp")) {
1547            $tempdir = File::Temp::tempdir("CHECKSUMS-XXXX", CLEANUP => 1, DIR => "/tmp" );
1548        } else {
1549            $tempdir = File::Spec->catdir(File::Spec->tmpdir, "CHECKSUMS-$$");
1550            File::Path::mkpath($tempdir);
1551        }
1552        my $tempfile = File::Spec->catfile($tempdir, "CHECKSUMS.$$");
1553        unlink $tempfile; # ignore missing file
1554        my $devnull = File::Spec->devnull;
1555        my $gpg = $CPAN::Config->{gpg} or
1556            $CPAN::Frontend->mydie("Your configuration suggests that you do not have 'gpg' installed. This is needed to verify checksums with the config variable 'check_sigs' on. Please configure it with 'o conf init gpg'");
1557        my $system = qq{"$gpg" --verify --batch --no-tty --output "$tempfile" "$chk_file" 2> "$devnull"};
1558        0 == system $system or $CPAN::Frontend->mydie("gpg run was failing, cannot continue: $system");
1559        open $fh, $tempfile or $CPAN::Frontend->mydie("Could not open $tempfile: $!");
1560        local $/;
1561        $signed_data = <$fh>;
1562        close $fh;
1563        File::Path::rmtree($tempdir);
1564    } else {
1565        my $fh = FileHandle->new;
1566        if (open $fh, $chk_file) {
1567            local($/);
1568            $signed_data = <$fh>;
1569        } else {
1570            $CPAN::Frontend->mydie("Could not open $chk_file for reading");
1571        }
1572        close $fh;
1573    }
1574    $signed_data =~ s/\015?\012/\n/g;
1575    my($compmt) = Safe->new();
1576    $cksum = $compmt->reval($signed_data);
1577    if ($@) {
1578        rename $chk_file, "$chk_file.bad";
1579        Carp::confess($@) if $@;
1580    }
1581
1582    if (! ref $cksum or ref $cksum ne "HASH") {
1583        $CPAN::Frontend->mywarn(qq{
1584Warning: checksum file '$chk_file' broken.
1585
1586When trying to read that file I expected to get a hash reference
1587for further processing, but got garbage instead.
1588});
1589        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
1590        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1591        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
1592        return;
1593    } elsif (exists $cksum->{$basename} && ! exists $cksum->{$basename}{cpan_path}) {
1594        $CPAN::Frontend->mywarn(qq{
1595Warning: checksum file '$chk_file' not conforming.
1596
1597The cksum does not contain the key 'cpan_path' for '$basename'.
1598});
1599        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
1600        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1601        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file without cpan_path";
1602        return;
1603    } elsif (exists $cksum->{$basename} && substr($self->{ID},0,length($cksum->{$basename}{cpan_path}))
1604             ne $cksum->{$basename}{cpan_path}) {
1605        $CPAN::Frontend->mywarn(qq{
1606Warning: checksum file not matching path '$self->{ID}'.
1607
1608The cksum contain the key 'cpan_path=$cksum->{$basename}{cpan_path}'
1609which does not match the ID of the distribution '$self->{ID}'.
1610Something's suspicious might be going on here. Please investigate.
1611
1612});
1613        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
1614        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1615        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS non-matching cpan_path vs. ID";
1616        return;
1617    } elsif (exists $cksum->{$basename}{sha256}) {
1618        $self->debug("Found checksum for $basename:" .
1619                     "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
1620
1621        open($fh, $file);
1622        binmode $fh;
1623        my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
1624        $fh->close;
1625        $fh = CPAN::Tarzip->TIEHANDLE($file);
1626
1627        unless ($eq) {
1628            my $dg = Digest::SHA->new(256);
1629            my($data,$ref);
1630            $ref = \$data;
1631            while ($fh->READ($ref, 4096) > 0) {
1632                $dg->add($data);
1633            }
1634            my $hexdigest = $dg->hexdigest;
1635            $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
1636        }
1637
1638        if ($eq) {
1639            $CPAN::Frontend->myprint("Checksum for $file ok\n");
1640            return $self->{CHECKSUM_STATUS} = "OK";
1641        } else {
1642            $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
1643                                     qq{distribution file. }.
1644                                     qq{Please investigate.\n\n}.
1645                                     $self->as_string,
1646                                     $CPAN::META->instance(
1647                                                           'CPAN::Author',
1648                                                           $self->cpan_userid
1649                                                          )->as_string);
1650
1651            my $wrap = qq{I\'d recommend removing $file. Its
1652checksum is incorrect. Maybe you have configured your 'urllist' with
1653a bad URL. Please check this array with 'o conf urllist', and
1654retry.};
1655
1656            $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
1657
1658            # former versions just returned here but this seems a
1659            # serious threat that deserves a die
1660
1661            # $CPAN::Frontend->myprint("\n\n");
1662            # sleep 3;
1663            # return;
1664        }
1665        # close $fh if fileno($fh);
1666    } else {
1667        return if $sloppy;
1668        unless ($self->{CHECKSUM_STATUS}) {
1669            $CPAN::Frontend->mywarn(qq{
1670Warning: No checksum for $basename in $chk_file.
1671
1672The cause for this may be that the file is very new and the checksum
1673has not yet been calculated, but it may also be that something is
1674going awry right now.
1675});
1676            my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
1677            $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
1678        }
1679        $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
1680        return;
1681    }
1682}
1683
1684#-> sub CPAN::Distribution::eq_CHECKSUM ;
1685sub eq_CHECKSUM {
1686    my($self,$fh,$expect) = @_;
1687    if ($CPAN::META->has_inst("Digest::SHA")) {
1688        my $dg = Digest::SHA->new(256);
1689        my($data);
1690        while (read($fh, $data, 4096)) {
1691            $dg->add($data);
1692        }
1693        my $hexdigest = $dg->hexdigest;
1694        # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
1695        return $hexdigest eq $expect;
1696    }
1697    return 1;
1698}
1699
1700#-> sub CPAN::Distribution::force ;
1701
1702# Both CPAN::Modules and CPAN::Distributions know if "force" is in
1703# effect by autoinspection, not by inspecting a global variable. One
1704# of the reason why this was chosen to work that way was the treatment
1705# of dependencies. They should not automatically inherit the force
1706# status. But this has the downside that ^C and die() will return to
1707# the prompt but will not be able to reset the force_update
1708# attributes. We try to correct for it currently in the read_metadata
1709# routine, and immediately before we check for a Signal. I hope this
1710# works out in one of v1.57_53ff
1711
1712# "Force get forgets previous error conditions"
1713
1714#-> sub CPAN::Distribution::fforce ;
1715sub fforce {
1716  my($self, $method) = @_;
1717  $self->force($method,1);
1718}
1719
1720#-> sub CPAN::Distribution::force ;
1721sub force {
1722  my($self, $method,$fforce) = @_;
1723  my %phase_map = (
1724                   get => [
1725                           "unwrapped",
1726                           "build_dir",
1727                           "archived",
1728                           "localfile",
1729                           "CHECKSUM_STATUS",
1730                           "signature_verify",
1731                           "prefs",
1732                           "prefs_file",
1733                           "prefs_file_doc",
1734                           "cleanup_after_install_done",
1735                          ],
1736                   make => [
1737                            "writemakefile",
1738                            "make",
1739                            "modulebuild",
1740                            "prereq_pm",
1741                            "cleanup_after_install_done",
1742                           ],
1743                   test => [
1744                            "badtestcnt",
1745                            "make_test",
1746                            "cleanup_after_install_done",
1747                          ],
1748                   install => [
1749                               "install",
1750                               "cleanup_after_install_done",
1751                              ],
1752                   unknown => [
1753                               "reqtype",
1754                               "yaml_content",
1755                               "cleanup_after_install_done",
1756                              ],
1757                  );
1758  my $methodmatch = 0;
1759  my $ldebug = 0;
1760 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
1761      $methodmatch = 1 if $fforce || ($method && $phase eq $method);
1762      next unless $methodmatch;
1763    ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
1764          if ($phase eq "get") {
1765              if (substr($self->id,-1,1) eq "."
1766                  && $att =~ /(unwrapped|build_dir|archived)/ ) {
1767                  # cannot be undone for local distros
1768                  next ATTRIBUTE;
1769              }
1770              if ($att eq "build_dir"
1771                  && $self->{build_dir}
1772                  && $CPAN::META->{is_tested}
1773                 ) {
1774                  delete $CPAN::META->{is_tested}{$self->{build_dir}};
1775              }
1776          } elsif ($phase eq "test") {
1777              if ($att eq "make_test"
1778                  && $self->{make_test}
1779                  && $self->{make_test}{COMMANDID}
1780                  && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
1781                 ) {
1782                  # endless loop too likely
1783                  next ATTRIBUTE;
1784              }
1785          }
1786          delete $self->{$att};
1787          if ($ldebug || $CPAN::DEBUG) {
1788              # local $CPAN::DEBUG = 16; # Distribution
1789              CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
1790          }
1791      }
1792  }
1793  if ($method && $method =~ /make|test|install/) {
1794    $self->{force_update} = 1; # name should probably have been force_install
1795  }
1796}
1797
1798#-> sub CPAN::Distribution::notest ;
1799sub notest {
1800  my($self, $method) = @_;
1801  # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
1802  $self->{"notest"}++; # name should probably have been force_install
1803}
1804
1805#-> sub CPAN::Distribution::unnotest ;
1806sub unnotest {
1807  my($self) = @_;
1808  # warn "XDEBUG: deleting notest";
1809  delete $self->{notest};
1810}
1811
1812#-> sub CPAN::Distribution::unforce ;
1813sub unforce {
1814  my($self) = @_;
1815  delete $self->{force_update};
1816}
1817
1818#-> sub CPAN::Distribution::isa_perl ;
1819sub isa_perl {
1820  my($self) = @_;
1821  my $file = File::Basename::basename($self->id);
1822  if ($file =~ m{ ^ perl
1823                  (
1824                   -(5\.\d+\.\d+)
1825                   |
1826                   (5)[._-](00[0-5](?:_[0-4][0-9])?)
1827                  )
1828                  \.tar[._-](?:gz|bz2)
1829                  (?!\n)\Z
1830                }xs) {
1831    my $perl_version;
1832    if ($2) {
1833        $perl_version = $2;
1834    } else {
1835        $perl_version = "$3.$4";
1836    }
1837    return $perl_version;
1838  } elsif ($self->cpan_comment
1839           &&
1840           $self->cpan_comment =~ /isa_perl\(.+?\)/) {
1841    return $1;
1842  }
1843}
1844
1845
1846#-> sub CPAN::Distribution::perl ;
1847sub perl {
1848    my ($self) = @_;
1849    if (! $self) {
1850        use Carp qw(carp);
1851        carp __PACKAGE__ . "::perl was called without parameters.";
1852    }
1853    return CPAN::HandleConfig->safe_quote($CPAN::Perl);
1854}
1855
1856#-> sub CPAN::Distribution::shortcut_prepare ;
1857# return values: undef means don't shortcut; 0 means shortcut as fail;
1858# and 1 means shortcut as success
1859
1860sub shortcut_prepare {
1861    my ($self) = @_;
1862
1863    $self->debug("checking archive type[$self->{ID}]") if $CPAN::DEBUG;
1864    if (!$self->{archived} || $self->{archived} eq "NO") {
1865        return $self->goodbye("Is neither a tar nor a zip archive.");
1866    }
1867
1868    $self->debug("checking unwrapping[$self->{ID}]") if $CPAN::DEBUG;
1869    if (!$self->{unwrapped}
1870        || (
1871            UNIVERSAL::can($self->{unwrapped},"failed") ?
1872            $self->{unwrapped}->failed :
1873            $self->{unwrapped} =~ /^NO/
1874            )) {
1875        return $self->goodbye("Had problems unarchiving. Please build manually");
1876    }
1877
1878    $self->debug("checking signature[$self->{ID}]") if $CPAN::DEBUG;
1879    if ( ! $self->{force_update}
1880        && exists $self->{signature_verify}
1881        && (
1882                UNIVERSAL::can($self->{signature_verify},"failed") ?
1883                $self->{signature_verify}->failed :
1884                $self->{signature_verify} =~ /^NO/
1885            )
1886    ) {
1887        return $self->goodbye("Did not pass the signature test.");
1888    }
1889
1890    $self->debug("checking writemakefile[$self->{ID}]") if $CPAN::DEBUG;
1891    if ($self->{writemakefile}) {
1892        if (
1893                UNIVERSAL::can($self->{writemakefile},"failed") ?
1894                $self->{writemakefile}->failed :
1895                $self->{writemakefile} =~ /^NO/
1896            ) {
1897            # XXX maybe a retry would be in order?
1898            my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
1899                $self->{writemakefile}->text :
1900                    $self->{writemakefile};
1901            $err =~ s/^NO\s*(--\s+)?//;
1902            $err ||= "Had some problem writing Makefile";
1903            $err .= ", not re-running";
1904            return $self->goodbye($err);
1905        } else {
1906            return $self->success("Has already been prepared");
1907        }
1908    }
1909
1910    $self->debug("checking configure_requires_later[$self->{ID}]") if $CPAN::DEBUG;
1911    if( my $later = $self->{configure_requires_later} ) { # see also undelay
1912        return $self->goodbye($later);
1913    }
1914
1915    return undef; # no shortcut
1916}
1917
1918sub prepare {
1919    my ($self) = @_;
1920
1921    $self->get
1922        or return;
1923
1924    if ( defined( my $sc = $self->shortcut_prepare) ) {
1925        return $sc;
1926    }
1927
1928    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
1929                           ? $ENV{PERL5LIB}
1930                           : ($ENV{PERLLIB} || "");
1931    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
1932    local $ENV{PERL_USE_UNSAFE_INC} =
1933        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
1934        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
1935    $CPAN::META->set_perl5lib;
1936    local $ENV{MAKEFLAGS}; # protect us from outer make calls
1937
1938    if ($CPAN::Signal) {
1939        delete $self->{force_update};
1940        return;
1941    }
1942
1943    my $builddir = $self->dir or
1944        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
1945
1946    unless (chdir $builddir) {
1947        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
1948        return;
1949    }
1950
1951    if ($CPAN::Signal) {
1952        delete $self->{force_update};
1953        return;
1954    }
1955
1956    $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
1957
1958    local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL} || '';
1959    local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL} || '';
1960    $self->choose_MM_or_MB
1961        or return;
1962
1963    my $configurator = $self->{configure} ? "Configure"
1964                     : $self->{modulebuild} ? "Build.PL"
1965                     : "Makefile.PL";
1966
1967    $CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");
1968
1969    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
1970        $ENV{PERL_AUTOINSTALL}          ||= "--defaultdeps";
1971        $ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
1972    }
1973
1974    my $system;
1975    my $pl_commandline;
1976    if ($self->prefs->{pl}) {
1977        $pl_commandline = $self->prefs->{pl}{commandline};
1978    }
1979    local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
1980    local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING} || '';
1981    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
1982    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
1983    if ($pl_commandline) {
1984        $system = $pl_commandline;
1985        $ENV{PERL} = $^X;
1986    } elsif ($self->{'configure'}) {
1987        $system = $self->{'configure'};
1988    } elsif ($self->{modulebuild}) {
1989        my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
1990        my $mbuildpl_arg = $self->_make_phase_arg("pl");
1991        $system = sprintf("%s Build.PL%s",
1992                          $perl,
1993                          $mbuildpl_arg ? " $mbuildpl_arg" : "",
1994                         );
1995    } else {
1996        my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
1997        my $switch = "";
1998# This needs a handler that can be turned on or off:
1999#        $switch = "-MExtUtils::MakeMaker ".
2000#            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
2001#            if $] > 5.00310;
2002        my $makepl_arg = $self->_make_phase_arg("pl");
2003        $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
2004                                                            "Makefile.PL");
2005        $system = sprintf("%s%s Makefile.PL%s",
2006                          $perl,
2007                          $switch ? " $switch" : "",
2008                          $makepl_arg ? " $makepl_arg" : "",
2009                         );
2010    }
2011    my $pl_env;
2012    if ($self->prefs->{pl}) {
2013        $pl_env = $self->prefs->{pl}{env};
2014    }
2015    local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
2016    if (exists $self->{writemakefile}) {
2017    } else {
2018        local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
2019        my($ret,$pid,$output);
2020        $@ = "";
2021        my $go_via_alarm;
2022        if ($CPAN::Config->{inactivity_timeout}) {
2023            require Config;
2024            if ($Config::Config{d_alarm}
2025                &&
2026                $Config::Config{d_alarm} eq "define"
2027               ) {
2028                $go_via_alarm++
2029            } else {
2030                $CPAN::Frontend->mywarn("Warning: you have configured the config ".
2031                                        "variable 'inactivity_timeout' to ".
2032                                        "'$CPAN::Config->{inactivity_timeout}'. But ".
2033                                        "on this machine the system call 'alarm' ".
2034                                        "isn't available. This means that we cannot ".
2035                                        "provide the feature of intercepting long ".
2036                                        "waiting code and will turn this feature off.\n"
2037                                       );
2038                $CPAN::Config->{inactivity_timeout} = 0;
2039            }
2040        }
2041        if ($go_via_alarm) {
2042            if ( $self->_should_report('pl') ) {
2043                ($output, $ret) = CPAN::Reporter::record_command(
2044                    $system,
2045                    $CPAN::Config->{inactivity_timeout},
2046                );
2047                CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
2048            }
2049            else {
2050                eval {
2051                    alarm $CPAN::Config->{inactivity_timeout};
2052                    local $SIG{CHLD}; # = sub { wait };
2053                    if (defined($pid = fork)) {
2054                        if ($pid) { #parent
2055                            # wait;
2056                            waitpid $pid, 0;
2057                        } else {    #child
2058                            # note, this exec isn't necessary if
2059                            # inactivity_timeout is 0. On the Mac I'd
2060                            # suggest, we set it always to 0.
2061                            exec $system;
2062                        }
2063                    } else {
2064                        $CPAN::Frontend->myprint("Cannot fork: $!");
2065                        return;
2066                    }
2067                };
2068                alarm 0;
2069                if ($@) {
2070                    kill 9, $pid;
2071                    waitpid $pid, 0;
2072                    my $err = "$@";
2073                    $CPAN::Frontend->myprint($err);
2074                    $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
2075                    $@ = "";
2076                    $self->store_persistent_state;
2077                    return $self->goodbye("$system -- TIMED OUT");
2078                }
2079            }
2080        } else {
2081            if (my $expect_model = $self->_prefs_with_expect("pl")) {
2082                # XXX probably want to check _should_report here and warn
2083                # about not being able to use CPAN::Reporter with expect
2084                $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
2085                if (! defined $ret
2086                    && $self->{writemakefile}
2087                    && $self->{writemakefile}->failed) {
2088                    # timeout
2089                    return;
2090                }
2091            }
2092            elsif ( $self->_should_report('pl') ) {
2093                ($output, $ret) = eval { CPAN::Reporter::record_command($system) };
2094                if (! defined $output or $@) {
2095                    my $err = $@ || "Unknown error";
2096                    $CPAN::Frontend->mywarn("Error while running PL phase: $err\n");
2097                    $self->{writemakefile} = CPAN::Distrostatus
2098                        ->new("NO '$system' returned status $ret and no output");
2099                    return $self->goodbye("$system -- NOT OK");
2100                }
2101                CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
2102            }
2103            else {
2104                $ret = system($system);
2105            }
2106            if ($ret != 0) {
2107                $self->{writemakefile} = CPAN::Distrostatus
2108                    ->new("NO '$system' returned status $ret");
2109                $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
2110                $self->store_persistent_state;
2111                return $self->goodbye("$system -- NOT OK");
2112            }
2113        }
2114        if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
2115            $self->{writemakefile} = CPAN::Distrostatus->new("YES");
2116            delete $self->{make_clean}; # if cleaned before, enable next
2117            $self->store_persistent_state;
2118            return $self->success("$system -- OK");
2119        } else {
2120            my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
2121            my $why = "No '$makefile' created";
2122            $CPAN::Frontend->mywarn($why);
2123            $self->{writemakefile} = CPAN::Distrostatus
2124                ->new(qq{NO -- $why\n});
2125            $self->store_persistent_state;
2126            return $self->goodbye("$system -- NOT OK");
2127        }
2128    }
2129    $self->store_persistent_state;
2130    return 1; # success
2131}
2132
2133#-> sub CPAN::Distribution::shortcut_make ;
2134# return values: undef means don't shortcut; 0 means shortcut as fail;
2135# and 1 means shortcut as success
2136sub shortcut_make {
2137    my ($self) = @_;
2138
2139    $self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
2140    if (defined $self->{make}) {
2141        if (UNIVERSAL::can($self->{make},"failed") ?
2142            $self->{make}->failed :
2143            $self->{make} =~ /^NO/
2144        ) {
2145            if ($self->{force_update}) {
2146                # Trying an already failed 'make' (unless somebody else blocks)
2147                return undef; # no shortcut
2148            } else {
2149                # introduced for turning recursion detection into a distrostatus
2150                my $error = length $self->{make}>3
2151                    ? substr($self->{make},3) : "Unknown error";
2152                $self->store_persistent_state;
2153                return $self->goodbye("Could not make: $error\n");
2154            }
2155        } else {
2156            return $self->success("Has already been made")
2157        }
2158    }
2159    return undef; # no shortcut
2160}
2161
2162#-> sub CPAN::Distribution::make ;
2163sub make {
2164    my($self) = @_;
2165
2166    $self->pre_make();
2167
2168    if (exists $self->{cleanup_after_install_done}) {
2169        $self->post_make();
2170        return $self->get;
2171    }
2172
2173    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
2174    if (my $goto = $self->prefs->{goto}) {
2175        $self->post_make();
2176        return $self->goto($goto);
2177    }
2178    # Emergency brake if they said install Pippi and get newest perl
2179
2180    # XXX Would this make more sense in shortcut_prepare, since
2181    # that doesn't make sense on a perl dist either?  Broader
2182    # question: what is the purpose of suggesting force install
2183    # on a perl distribution?  That seems unlikely to result in
2184    # such a dependency being satisfied, even if the perl is
2185    # successfully installed.  This situation is tantamount to
2186    # a prereq on a version of perl greater than the current one
2187    # so I think we should just abort. -- xdg, 2012-04-06
2188    if ($self->isa_perl) {
2189        if (
2190            $self->called_for ne $self->id &&
2191            ! $self->{force_update}
2192        ) {
2193            # if we die here, we break bundles
2194            $CPAN::Frontend
2195                ->mywarn(sprintf(
2196                            qq{The most recent version "%s" of the module "%s"
2197is part of the perl-%s distribution. To install that, you need to run
2198  force install %s   --or--
2199  install %s
2200},
2201                             $CPAN::META->instance(
2202                                                   'CPAN::Module',
2203                                                   $self->called_for
2204                                                  )->cpan_version,
2205                             $self->called_for,
2206                             $self->isa_perl,
2207                             $self->called_for,
2208                             $self->pretty_id,
2209                            ));
2210            $self->{make} = CPAN::Distrostatus->new("NO isa perl");
2211            $CPAN::Frontend->mysleep(1);
2212            $self->post_make();
2213            return;
2214        }
2215    }
2216
2217    unless ($self->prepare){
2218        $self->post_make();
2219        return;
2220    }
2221
2222    if ( defined( my $sc = $self->shortcut_make) ) {
2223        $self->post_make();
2224        return $sc;
2225    }
2226
2227    if ($CPAN::Signal) {
2228        delete $self->{force_update};
2229        $self->post_make();
2230        return;
2231    }
2232
2233    my $builddir = $self->dir or
2234        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
2235
2236    unless (chdir $builddir) {
2237        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
2238        $self->post_make();
2239        return;
2240    }
2241
2242    my $make = $self->{modulebuild} ? "Build" : "make";
2243    $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
2244    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
2245                           ? $ENV{PERL5LIB}
2246                           : ($ENV{PERLLIB} || "");
2247    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
2248    local $ENV{PERL_USE_UNSAFE_INC} =
2249        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
2250        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
2251    $CPAN::META->set_perl5lib;
2252    local $ENV{MAKEFLAGS}; # protect us from outer make calls
2253
2254    if ($CPAN::Signal) {
2255        delete $self->{force_update};
2256        $self->post_make();
2257        return;
2258    }
2259
2260    if ($^O eq 'MacOS') {
2261        Mac::BuildTools::make($self);
2262        $self->post_make();
2263        return;
2264    }
2265
2266    my %env;
2267    while (my($k,$v) = each %ENV) {
2268        next if defined $v;
2269        $env{$k} = '';
2270    }
2271    local @ENV{keys %env} = values %env;
2272    my $satisfied = eval { $self->satisfy_requires };
2273    if ($@) {
2274        return $self->goodbye($@);
2275    }
2276    unless ($satisfied){
2277        $self->post_make();
2278        return;
2279    }
2280    if ($CPAN::Signal) {
2281        delete $self->{force_update};
2282        $self->post_make();
2283        return;
2284    }
2285
2286    # need to chdir again, because $self->satisfy_requires might change the directory
2287    unless (chdir $builddir) {
2288        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
2289        $self->post_make();
2290        return;
2291    }
2292
2293    my $system;
2294    my $make_commandline;
2295    if ($self->prefs->{make}) {
2296        $make_commandline = $self->prefs->{make}{commandline};
2297    }
2298    local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
2299    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
2300    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
2301    if ($make_commandline) {
2302        $system = $make_commandline;
2303        $ENV{PERL} = CPAN::find_perl();
2304    } else {
2305        if ($self->{modulebuild}) {
2306            unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
2307                my $cwd = CPAN::anycwd();
2308                $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
2309                                        " in cwd[$cwd]. Danger, Will Robinson!\n");
2310                $CPAN::Frontend->mysleep(5);
2311            }
2312            $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
2313        } else {
2314            $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
2315        }
2316        $system =~ s/\s+$//;
2317        my $make_arg = $self->_make_phase_arg("make");
2318        $system = sprintf("%s%s",
2319                          $system,
2320                          $make_arg ? " $make_arg" : "",
2321                         );
2322    }
2323    my $make_env;
2324    if ($self->prefs->{make}) {
2325        $make_env = $self->prefs->{make}{env};
2326    }
2327    local @ENV{keys %$make_env} = values %$make_env if $make_env;
2328    my $expect_model = $self->_prefs_with_expect("make");
2329    my $want_expect = 0;
2330    if ( $expect_model && @{$expect_model->{talk}} ) {
2331        my $can_expect = $CPAN::META->has_inst("Expect");
2332        if ($can_expect) {
2333            $want_expect = 1;
2334        } else {
2335            $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
2336                                    "system()\n");
2337        }
2338    }
2339    my ($system_ok, $system_err);
2340    if ($want_expect) {
2341        # XXX probably want to check _should_report here and
2342        # warn about not being able to use CPAN::Reporter with expect
2343        $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
2344    }
2345    elsif ( $self->_should_report('make') ) {
2346        my ($output, $ret) = CPAN::Reporter::record_command($system);
2347        CPAN::Reporter::grade_make( $self, $system, $output, $ret );
2348        $system_ok = ! $ret;
2349    }
2350    else {
2351        my $rc = system($system);
2352        $system_ok = $rc == 0;
2353        $system_err = $! if $rc == -1;
2354    }
2355    $self->introduce_myself;
2356    if ( $system_ok ) {
2357        $CPAN::Frontend->myprint("  $system -- OK\n");
2358        $self->{make} = CPAN::Distrostatus->new("YES");
2359    } else {
2360        $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
2361        $self->{make} = CPAN::Distrostatus->new("NO");
2362        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
2363        $CPAN::Frontend->mywarn("  $system_err\n") if defined $system_err;
2364    }
2365    $self->store_persistent_state;
2366
2367    $self->post_make();
2368
2369    return !! $system_ok;
2370}
2371
2372# CPAN::Distribution::goodbye ;
2373sub goodbye {
2374    my($self,$goodbye) = @_;
2375    my $id = $self->pretty_id;
2376    $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
2377    return 0; # must be explicit false, not undef
2378}
2379
2380sub success {
2381    my($self,$why) = @_;
2382    my $id = $self->pretty_id;
2383    $CPAN::Frontend->myprint("  $id\n  $why\n");
2384    return 1;
2385}
2386
2387# CPAN::Distribution::_run_via_expect ;
2388sub _run_via_expect {
2389    my($self,$system,$phase,$expect_model) = @_;
2390    CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
2391    if ($CPAN::META->has_inst("Expect")) {
2392        my $expo = Expect->new;  # expo Expect object;
2393        $expo->spawn($system);
2394        $expect_model->{mode} ||= "deterministic";
2395        if ($expect_model->{mode} eq "deterministic") {
2396            return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
2397        } elsif ($expect_model->{mode} eq "anyorder") {
2398            return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
2399        } else {
2400            die "Panic: Illegal expect mode: $expect_model->{mode}";
2401        }
2402    } else {
2403        $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
2404        return system($system);
2405    }
2406}
2407
2408sub _run_via_expect_anyorder {
2409    my($self,$expo,$phase,$expect_model) = @_;
2410    my $timeout = $expect_model->{timeout} || 5;
2411    my $reuse = $expect_model->{reuse};
2412    my @expectacopy = @{$expect_model->{talk}}; # we trash it!
2413    my $but = "";
2414    my $timeout_start = time;
2415  EXPECT: while () {
2416        my($eof,$ran_into_timeout);
2417        # XXX not up to the full power of expect. one could certainly
2418        # wrap all of the talk pairs into a single expect call and on
2419        # success tweak it and step ahead to the next question. The
2420        # current implementation unnecessarily limits itself to a
2421        # single match.
2422        my @match = $expo->expect(1,
2423                                  [ eof => sub {
2424                                        $eof++;
2425                                    } ],
2426                                  [ timeout => sub {
2427                                        $ran_into_timeout++;
2428                                    } ],
2429                                  -re => eval"qr{.}",
2430                                 );
2431        if ($match[2]) {
2432            $but .= $match[2];
2433        }
2434        $but .= $expo->clear_accum;
2435        if ($eof) {
2436            $expo->soft_close;
2437            return $expo->exitstatus();
2438        } elsif ($ran_into_timeout) {
2439            # warn "DEBUG: they are asking a question, but[$but]";
2440            for (my $i = 0; $i <= $#expectacopy; $i+=2) {
2441                my($next,$send) = @expectacopy[$i,$i+1];
2442                my $regex = eval "qr{$next}";
2443                # warn "DEBUG: will compare with regex[$regex].";
2444                if ($but =~ /$regex/) {
2445                    # warn "DEBUG: will send send[$send]";
2446                    $expo->send($send);
2447                    # never allow reusing an QA pair unless they told us
2448                    splice @expectacopy, $i, 2 unless $reuse;
2449                    $but =~ s/(?s:^.*?)$regex//;
2450                    $timeout_start = time;
2451                    next EXPECT;
2452                }
2453            }
2454            my $have_waited = time - $timeout_start;
2455            if ($have_waited < $timeout) {
2456                # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
2457                next EXPECT;
2458            }
2459            my $why = "could not answer a question during the dialog";
2460            $CPAN::Frontend->mywarn("Failing: $why\n");
2461            $self->{$phase} =
2462                CPAN::Distrostatus->new("NO $why");
2463            return 0;
2464        }
2465    }
2466}
2467
2468sub _run_via_expect_deterministic {
2469    my($self,$expo,$phase,$expect_model) = @_;
2470    my $ran_into_timeout;
2471    my $ran_into_eof;
2472    my $timeout = $expect_model->{timeout} || 15; # currently unsettable
2473    my $expecta = $expect_model->{talk};
2474  EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
2475        my($re,$send) = @$expecta[$i,$i+1];
2476        CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
2477        my $regex = eval "qr{$re}";
2478        $expo->expect($timeout,
2479                      [ eof => sub {
2480                            my $but = $expo->clear_accum;
2481                            $CPAN::Frontend->mywarn("EOF (maybe harmless)
2482expected[$regex]\nbut[$but]\n\n");
2483                            $ran_into_eof++;
2484                        } ],
2485                      [ timeout => sub {
2486                            my $but = $expo->clear_accum;
2487                            $CPAN::Frontend->mywarn("TIMEOUT
2488expected[$regex]\nbut[$but]\n\n");
2489                            $ran_into_timeout++;
2490                        } ],
2491                      -re => $regex);
2492        if ($ran_into_timeout) {
2493            # note that the caller expects 0 for success
2494            $self->{$phase} =
2495                CPAN::Distrostatus->new("NO timeout during expect dialog");
2496            return 0;
2497        } elsif ($ran_into_eof) {
2498            last EXPECT;
2499        }
2500        $expo->send($send);
2501    }
2502    $expo->soft_close;
2503    return $expo->exitstatus();
2504}
2505
2506#-> CPAN::Distribution::_validate_distropref
2507sub _validate_distropref {
2508    my($self,@args) = @_;
2509    if (
2510        $CPAN::META->has_inst("CPAN::Kwalify")
2511        &&
2512        $CPAN::META->has_inst("Kwalify")
2513       ) {
2514        eval {CPAN::Kwalify::_validate("distroprefs",@args);};
2515        if ($@) {
2516            $CPAN::Frontend->mywarn($@);
2517        }
2518    } else {
2519        CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
2520    }
2521}
2522
2523#-> CPAN::Distribution::_find_prefs
2524sub _find_prefs {
2525    my($self) = @_;
2526    my $distroid = $self->pretty_id;
2527    #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
2528    my $prefs_dir = $CPAN::Config->{prefs_dir};
2529    return if $prefs_dir =~ /^\s*$/;
2530    eval { File::Path::mkpath($prefs_dir); };
2531    if ($@) {
2532        $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
2533    }
2534    # shortcut if there are no distroprefs files
2535    {
2536      my $dh = DirHandle->new($prefs_dir) or $CPAN::Frontend->mydie("Couldn't open '$prefs_dir': $!");
2537      my @files = map { /\.(yml|dd|st)\z/i } $dh->read;
2538      return unless @files;
2539    }
2540    my $yaml_module = CPAN::_yaml_module();
2541    my $ext_map = {};
2542    my @extensions;
2543    if ($CPAN::META->has_inst($yaml_module)) {
2544        $ext_map->{yml} = 'CPAN';
2545    } else {
2546        my @fallbacks;
2547        if ($CPAN::META->has_inst("Data::Dumper")) {
2548            push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
2549        }
2550        if ($CPAN::META->has_inst("Storable")) {
2551            push @fallbacks, $ext_map->{st} = 'Storable';
2552        }
2553        if (@fallbacks) {
2554            local $" = " and ";
2555            unless ($self->{have_complained_about_missing_yaml}++) {
2556                $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, falling back ".
2557                                            "to @fallbacks to read prefs '$prefs_dir'\n");
2558            }
2559        } else {
2560            unless ($self->{have_complained_about_missing_yaml}++) {
2561                $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, cannot ".
2562                                            "read prefs '$prefs_dir'\n");
2563            }
2564        }
2565    }
2566    my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
2567    DIRENT: while (my $result = $finder->next) {
2568        if ($result->is_warning) {
2569            $CPAN::Frontend->mywarn($result->as_string);
2570            $CPAN::Frontend->mysleep(1);
2571            next DIRENT;
2572        } elsif ($result->is_fatal) {
2573            $CPAN::Frontend->mydie($result->as_string);
2574        }
2575
2576        my @prefs = @{ $result->prefs };
2577
2578      ELEMENT: for my $y (0..$#prefs) {
2579            my $pref = $prefs[$y];
2580            $self->_validate_distropref($pref->data, $result->abs, $y);
2581
2582            # I don't know why we silently skip when there's no match, but
2583            # complain if there's an empty match hashref, and there's no
2584            # comment explaining why -- hdp, 2008-03-18
2585            unless ($pref->has_any_match) {
2586                next ELEMENT;
2587            }
2588
2589            unless ($pref->has_valid_subkeys) {
2590                $CPAN::Frontend->mydie(sprintf
2591                    "Nonconforming .%s file '%s': " .
2592                    "missing match/* subattribute. " .
2593                    "Please remove, cannot continue.",
2594                    $result->ext, $result->abs,
2595                );
2596            }
2597
2598            my $arg = {
2599                env          => \%ENV,
2600                distribution => $distroid,
2601                perl         => \&CPAN::find_perl,
2602                perlconfig   => \%Config::Config,
2603                module       => sub { [ $self->containsmods ] },
2604            };
2605
2606            if ($pref->matches($arg)) {
2607                return {
2608                    prefs => $pref->data,
2609                    prefs_file => $result->abs,
2610                    prefs_file_doc => $y,
2611                };
2612            }
2613
2614        }
2615    }
2616    return;
2617}
2618
2619# CPAN::Distribution::prefs
2620sub prefs {
2621    my($self) = @_;
2622    if (exists $self->{negative_prefs_cache}
2623        &&
2624        $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
2625       ) {
2626        delete $self->{negative_prefs_cache};
2627        delete $self->{prefs};
2628    }
2629    if (exists $self->{prefs}) {
2630        return $self->{prefs}; # XXX comment out during debugging
2631    }
2632    if ($CPAN::Config->{prefs_dir}) {
2633        CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
2634        my $prefs = $self->_find_prefs();
2635        $prefs ||= ""; # avoid warning next line
2636        CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
2637        if ($prefs) {
2638            for my $x (qw(prefs prefs_file prefs_file_doc)) {
2639                $self->{$x} = $prefs->{$x};
2640            }
2641            my $bs = sprintf(
2642                             "%s[%s]",
2643                             File::Basename::basename($self->{prefs_file}),
2644                             $self->{prefs_file_doc},
2645                            );
2646            my $filler1 = "_" x 22;
2647            my $filler2 = int(66 - length($bs))/2;
2648            $filler2 = 0 if $filler2 < 0;
2649            $filler2 = " " x $filler2;
2650            $CPAN::Frontend->myprint("
2651$filler1 D i s t r o P r e f s $filler1
2652$filler2 $bs $filler2
2653");
2654            $CPAN::Frontend->mysleep(1);
2655            return $self->{prefs};
2656        }
2657    }
2658    $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
2659    return $self->{prefs} = +{};
2660}
2661
2662# CPAN::Distribution::_make_phase_arg
2663sub _make_phase_arg {
2664    my($self, $phase) = @_;
2665    my $_make_phase_arg;
2666    my $prefs = $self->prefs;
2667    if (
2668        $prefs
2669        && exists $prefs->{$phase}
2670        && exists $prefs->{$phase}{args}
2671        && $prefs->{$phase}{args}
2672       ) {
2673        $_make_phase_arg = join(" ",
2674                           map {CPAN::HandleConfig
2675                                 ->safe_quote($_)} @{$prefs->{$phase}{args}},
2676                          );
2677    }
2678
2679# cpan[2]> o conf make[TAB]
2680# make                       make_install_make_command
2681# make_arg                   makepl_arg
2682# make_install_arg
2683# cpan[2]> o conf mbuild[TAB]
2684# mbuild_arg                    mbuild_install_build_command
2685# mbuild_install_arg            mbuildpl_arg
2686
2687    my $mantra; # must switch make/mbuild here
2688    if ($self->{modulebuild}) {
2689        $mantra = "mbuild";
2690    } else {
2691        $mantra = "make";
2692    }
2693    my %map = (
2694               pl => "pl_arg",
2695               make => "_arg",
2696               test => "_test_arg", # does not really exist but maybe
2697                                    # will some day and now protects
2698                                    # us from unini warnings
2699               install => "_install_arg",
2700              );
2701    my $phase_underscore_meshup = $map{$phase};
2702    my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
2703
2704    $_make_phase_arg ||= $CPAN::Config->{$what};
2705    return $_make_phase_arg;
2706}
2707
2708# CPAN::Distribution::_make_command
2709sub _make_command {
2710    my ($self) = @_;
2711    if ($self) {
2712        return
2713            CPAN::HandleConfig
2714                ->safe_quote(
2715                             CPAN::HandleConfig->prefs_lookup($self,
2716                                                              q{make})
2717                             || $Config::Config{make}
2718                             || 'make'
2719                            );
2720    } else {
2721        # Old style call, without object. Deprecated
2722        Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
2723        return
2724          safe_quote(undef,
2725                     CPAN::HandleConfig->prefs_lookup($self,q{make})
2726                     || $CPAN::Config->{make}
2727                     || $Config::Config{make}
2728                     || 'make');
2729    }
2730}
2731
2732sub _make_install_make_command {
2733    my ($self) = @_;
2734    my $mimc =
2735        CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
2736    return $self->_make_command() unless $mimc;
2737
2738    # Quote the "make install" make command on Windows, where it is commonly
2739    # found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
2740    # do this in general because the command maybe "sudo make..." (i.e. a
2741    # program with arguments), but that is unlikely to be the case on Windows.
2742    $mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';
2743
2744    return $mimc;
2745}
2746
2747#-> sub CPAN::Distribution::is_locally_optional
2748sub is_locally_optional {
2749    my($self, $prereq_pm, $prereq) = @_;
2750    $prereq_pm ||= $self->{prereq_pm};
2751    my($nmo,$opt);
2752    for my $rt (qw(requires build_requires)) {
2753        if (exists $prereq_pm->{$rt}{$prereq}) {
2754            # rt 121914
2755            $nmo ||= $CPAN::META->instance("CPAN::Module",$prereq);
2756            my $av = $nmo->available_version;
2757            return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq});
2758        }
2759        if (exists $prereq_pm->{"opt_$rt"}{$prereq}) {
2760            $opt = 1;
2761        }
2762    }
2763    return $opt||0;
2764}
2765
2766#-> sub CPAN::Distribution::follow_prereqs ;
2767sub follow_prereqs {
2768    my($self) = shift;
2769    my($slot) = shift;
2770    my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
2771    return unless @prereq_tuples;
2772    my(@good_prereq_tuples);
2773    for my $p (@prereq_tuples) {
2774        # e.g. $p = ['Devel::PartialDump', 'r', 1]
2775        # promote if possible
2776        if ($p->[1] =~ /^(r|c)$/) {
2777            push @good_prereq_tuples, $p;
2778        } elsif ($p->[1] =~ /^(b)$/) {
2779            my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
2780            if ($reqtype =~ /^(r|c)$/) {
2781                push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
2782            } else {
2783                push @good_prereq_tuples, $p;
2784            }
2785        } else {
2786            die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
2787        }
2788    }
2789    my $pretty_id = $self->pretty_id;
2790    my %map = (
2791               b => "build_requires",
2792               r => "requires",
2793               c => "commandline",
2794              );
2795    my($filler1,$filler2,$filler3,$filler4);
2796    my $unsat = "Unsatisfied dependencies detected during";
2797    my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
2798    {
2799        my $r = int(($w - length($unsat))/2);
2800        my $l = $w - length($unsat) - $r;
2801        $filler1 = "-"x4 . " "x$l;
2802        $filler2 = " "x$r . "-"x4 . "\n";
2803    }
2804    {
2805        my $r = int(($w - length($pretty_id))/2);
2806        my $l = $w - length($pretty_id) - $r;
2807        $filler3 = "-"x4 . " "x$l;
2808        $filler4 = " "x$r . "-"x4 . "\n";
2809    }
2810    $CPAN::Frontend->
2811        myprint("$filler1 $unsat $filler2".
2812                "$filler3 $pretty_id $filler4".
2813                join("", map {sprintf "    %s \[%s%s]\n", $_->[0], $map{$_->[1]}, $self->is_locally_optional(undef,$_->[0]) ? ",optional" : ""} @good_prereq_tuples),
2814               );
2815    my $follow = 0;
2816    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
2817        $follow = 1;
2818    } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
2819        my $answer = CPAN::Shell::colorable_makemaker_prompt(
2820"Shall I follow them and prepend them to the queue
2821of modules we are processing right now?", "yes");
2822        $follow = $answer =~ /^\s*y/i;
2823    } else {
2824        my @prereq = map { $_->[0] } @good_prereq_tuples;
2825        local($") = ", ";
2826        $CPAN::Frontend->
2827            myprint("  Ignoring dependencies on modules @prereq\n");
2828    }
2829    if ($follow) {
2830        my $id = $self->id;
2831        my(@to_queue_mand,@to_queue_opt);
2832        for my $gp (@good_prereq_tuples) {
2833            my($prereq,$reqtype,$optional) = @$gp;
2834            my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
2835            if ($optional &&
2836                $self->is_locally_optional(undef,$prereq)
2837               ){
2838                # Since we do not depend on this one, we do not need
2839                # this in a mandatory arrangement:
2840                push @to_queue_opt, $qthing;
2841            } else {
2842                my $any = CPAN::Shell->expandany($prereq);
2843                $self->{$slot . "_for"}{$any->id}++;
2844                if ($any) {
2845                    unless ($optional) {
2846                        # No recursion check in an optional area of the tree
2847                        $any->color_cmd_tmps(0,2);
2848                    }
2849                } else {
2850                    $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
2851                    $CPAN::Frontend->mysleep(2);
2852                }
2853                # order everything that is not locally_optional just
2854                # like mandatory items: this keeps leaves before
2855                # branches
2856                unshift @to_queue_mand, $qthing;
2857            }
2858        }
2859        if (@to_queue_mand) {
2860            unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
2861            CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
2862            $self->{$slot} = "Delayed until after prerequisites";
2863            return 1; # signal we need dependencies
2864        } elsif (@to_queue_opt) {
2865            CPAN::Queue->jumpqueue(@to_queue_opt);
2866        }
2867    }
2868    return;
2869}
2870
2871sub _feature_depends {
2872    my($self) = @_;
2873    my $meta_yml = $self->parse_meta_yml();
2874    my $optf = $meta_yml->{optional_features} or return;
2875    if (!ref $optf or ref $optf ne "HASH"){
2876        $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
2877        $optf = {};
2878    }
2879    my $wantf = $self->prefs->{features} or return;
2880    if (!ref $wantf or ref $wantf ne "ARRAY"){
2881        $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
2882        $wantf = [];
2883    }
2884    my $dep = +{};
2885    for my $wf (@$wantf) {
2886        if (my $f = $optf->{$wf}) {
2887            $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
2888                                     "is accompanied by this description:\n".
2889                                     $f->{description}.
2890                                     "\n\n"
2891                                    );
2892            # configure_requires currently not in the spec, unlikely to be useful anyway
2893            for my $reqtype (qw(configure_requires build_requires requires)) {
2894                my $reqhash = $f->{$reqtype} or next;
2895                while (my($k,$v) = each %$reqhash) {
2896                    $dep->{$reqtype}{$k} = $v;
2897                }
2898            }
2899        } else {
2900            $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
2901                                    "found in the META.yml file".
2902                                    "\n\n"
2903                                   );
2904        }
2905    }
2906    $dep;
2907}
2908
2909sub prereqs_for_slot {
2910    my($self,$slot) = @_;
2911    my($prereq_pm);
2912    unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
2913        my $whynot = "not available";
2914        if (defined $CPAN::Meta::Requirements::VERSION) {
2915            $whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient";
2916        }
2917        $CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n");
2918        my $before = "";
2919        if ($self->{CALLED_FOR}){
2920            if ($self->{CALLED_FOR} =~
2921                /^(
2922                     CPAN::Meta::Requirements
2923                 |CPAN::DistnameInfo
2924                 |version
2925                 |parent
2926                 |ExtUtils::MakeMaker
2927                 |Test::Harness
2928                 )$/x) {
2929                $CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ".
2930                    "as soon as possible; it is needed for a reliable operation of ".
2931                    "the cpan shell; setting requirements to nil for '$1' for now ".
2932                    "to prevent deadlock during bootstrapping\n");
2933                return;
2934            }
2935            $before = " before $self->{CALLED_FOR}";
2936        }
2937        $CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before");
2938    }
2939    my $merged = CPAN::Meta::Requirements->new;
2940    my $prefs_depends = $self->prefs->{depends}||{};
2941    my $feature_depends = $self->_feature_depends();
2942    if ($slot eq "configure_requires_later") {
2943        for my $hash (  $self->configure_requires,
2944                        $prefs_depends->{configure_requires},
2945                        $feature_depends->{configure_requires},
2946        ) {
2947            $merged->add_requirements(
2948                CPAN::Meta::Requirements->from_string_hash($hash)
2949            );
2950        }
2951        if (-f "Build.PL"
2952            && ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
2953            && ! @{[ $merged->required_modules ]}
2954            && ! $CPAN::META->has_inst("Module::Build")
2955           ) {
2956            $CPAN::Frontend->mywarn(
2957              "  Warning: CPAN.pm discovered Module::Build as undeclared prerequisite.\n".
2958              "  Adding it now as such.\n"
2959            );
2960            $CPAN::Frontend->mysleep(5);
2961            $merged->add_minimum( "Module::Build" => 0 );
2962            delete $self->{writemakefile};
2963        }
2964        $prereq_pm = {}; # configure_requires defined as "b"
2965    } elsif ($slot eq "later") {
2966        my $prereq_pm_0 = $self->prereq_pm || {};
2967        for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
2968            $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
2969            for my $dep ($prefs_depends,$feature_depends) {
2970                for my $k (keys %{$dep->{$reqtype}||{}}) {
2971                    $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
2972                }
2973            }
2974        }
2975        # XXX what about optional_req|breq? -- xdg, 2012-04-01
2976        for my $hash (
2977            $prereq_pm->{requires},
2978            $prereq_pm->{build_requires},
2979            $prereq_pm->{opt_requires},
2980            $prereq_pm->{opt_build_requires},
2981
2982        ) {
2983            $merged->add_requirements(
2984                CPAN::Meta::Requirements->from_string_hash($hash)
2985            );
2986        }
2987    } else {
2988        die "Panic: illegal slot '$slot'";
2989    }
2990    return ($merged->as_string_hash, $prereq_pm);
2991}
2992
2993#-> sub CPAN::Distribution::unsat_prereq ;
2994# return ([Foo,"r"],[Bar,"b"]) for normal modules
2995# return ([perl=>5.008]) if we need a newer perl than we are running under
2996# (sorry for the inconsistency, it was an accident)
2997sub unsat_prereq {
2998    my($self,$slot) = @_;
2999    my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
3000    my(@need);
3001    unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
3002        $CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n");
3003        return;
3004    }
3005    my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
3006    my @merged = sort $merged->required_modules;
3007    CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
3008  NEED: for my $need_module ( @merged ) {
3009        my $need_version = $merged->requirements_for_module($need_module);
3010        my($available_version,$inst_file,$available_file,$nmo);
3011        if ($need_module eq "perl") {
3012            $available_version = $];
3013            $available_file = CPAN::find_perl();
3014        } else {
3015            if (CPAN::_sqlite_running()) {
3016                CPAN::Index->reload;
3017                $CPAN::SQLite->search("CPAN::Module",$need_module);
3018            }
3019            $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
3020            $inst_file = $nmo->inst_file || '';
3021            $available_file = $nmo->available_file || '';
3022            $available_version = $nmo->available_version;
3023            if ($nmo->uptodate) {
3024                my $accepts = eval {
3025                    $merged->accepts_module($need_module, $available_version);
3026                };
3027                unless ($accepts) {
3028                    my $rq = $merged->requirements_for_module( $need_module );
3029                    $CPAN::Frontend->mywarn(
3030                        "Warning: Version '$available_version' of ".
3031                        "'$need_module' is up to date but does not ".
3032                        "fulfill requirements ($rq). I will continue, ".
3033                        "but chances to succeed are low.\n");
3034                }
3035                next NEED;
3036            }
3037
3038            # if they have not specified a version, we accept any
3039            # installed one; in that case inst_file is always
3040            # sufficient and available_file is sufficient on
3041            # both build_requires and configure_requires
3042            my $sufficient = $inst_file ||
3043                ( exists $prereq_pm->{requires}{$need_module} ? 0 : $available_file );
3044            if ( $sufficient
3045                and ( # a few quick short circuits
3046                     not defined $need_version
3047                     or $need_version eq '0'    # "==" would trigger warning when not numeric
3048                     or $need_version eq "undef"
3049                    )) {
3050                unless ($nmo->inst_deprecated) {
3051                    next NEED;
3052                }
3053            }
3054        }
3055
3056        # We only want to install prereqs if either they're not installed
3057        # or if the installed version is too old. We cannot omit this
3058        # check, because if 'force' is in effect, nobody else will check.
3059        # But we don't want to accept a deprecated module installed as part
3060        # of the Perl core, so we continue if the available file is the installed
3061        # one and is deprecated
3062
3063        if ( $available_file ) {
3064            my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
3065                (
3066                 $need_module,
3067                 $available_file,
3068                 $available_version,
3069                 $need_version,
3070                );
3071            if ( $inst_file
3072                       && $available_file eq $inst_file
3073                       && $nmo->inst_deprecated
3074                     ) {
3075                # continue installing as a prereq. we really want that
3076                # because the deprecated module may spit out warnings
3077                # and third party did not know until today. Only one
3078                # exception is OK, because CPANPLUS is special after
3079                # all:
3080                if ( $fulfills_all_version_rqs and
3081                     $nmo->id =~ /^CPANPLUS(?:::Dist::Build)$/
3082                   ) {
3083                    # here we have an available version that is good
3084                    # enough although deprecated (preventing circular
3085                    # loop CPANPLUS => CPANPLUS::Dist::Build RT#83042)
3086                    next NEED;
3087                }
3088            } elsif (
3089                $self->{reqtype} # e.g. maybe we came via goto?
3090                && $self->{reqtype} =~ /^(r|c)$/
3091                && (   exists $prereq_pm->{requires}{$need_module}
3092                    || exists $prereq_pm->{opt_requires}{$need_module} )
3093                && $nmo
3094                && !$inst_file
3095            ) {
3096                # continue installing as a prereq; this may be a
3097                # distro we already used when it was a build_requires
3098                # so we did not install it. But suddenly somebody
3099                # wants it as a requires
3100                my $need_distro = $nmo->distribution;
3101                if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) {
3102                    my $id = $need_distro->pretty_id;
3103                    $CPAN::Frontend->myprint("Promoting $id from build_requires to requires due $need_module\n");
3104                    delete $need_distro->{install}; # promote to another installation attempt
3105                    $need_distro->{reqtype} = "r";
3106                    $need_distro->install;
3107                    next NEED;
3108                }
3109            }
3110            else {
3111                next NEED if $fulfills_all_version_rqs;
3112            }
3113        }
3114
3115        if ($need_module eq "perl") {
3116            return ["perl", $need_version];
3117        }
3118        $self->{sponsored_mods}{$need_module} ||= 0;
3119        CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
3120        if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
3121            # We have already sponsored it and for some reason it's still
3122            # not available. So we do ... what??
3123
3124            # if we push it again, we have a potential infinite loop
3125
3126            # The following "next" was a very problematic construct.
3127            # It helped a lot but broke some day and had to be
3128            # replaced.
3129
3130            # We must be able to deal with modules that come again and
3131            # again as a prereq and have themselves prereqs and the
3132            # queue becomes long but finally we would find the correct
3133            # order. The RecursiveDependency check should trigger a
3134            # die when it's becoming too weird. Unfortunately removing
3135            # this next breaks many other things.
3136
3137            # The bug that brought this up is described in Todo under
3138            # "5.8.9 cannot install Compress::Zlib"
3139
3140            # next; # this is the next that had to go away
3141
3142            # The following "next NEED" are fine and the error message
3143            # explains well what is going on. For example when the DBI
3144            # fails and consequently DBD::SQLite fails and now we are
3145            # processing CPAN::SQLite. Then we must have a "next" for
3146            # DBD::SQLite. How can we get it and how can we identify
3147            # all other cases we must identify?
3148
3149            my $do = $nmo->distribution;
3150            next NEED unless $do; # not on CPAN
3151            if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
3152                $CPAN::Frontend->mywarn("Warning: Prerequisite ".
3153                                        "'$need_module => $need_version' ".
3154                                        "for '$self->{ID}' seems ".
3155                                        "not available according to the indices\n"
3156                                       );
3157                next NEED;
3158            }
3159          NOSAYER: for my $nosayer (
3160                                    "unwrapped",
3161                                    "writemakefile",
3162                                    "signature_verify",
3163                                    "make",
3164                                    "make_test",
3165                                    "install",
3166                                    "make_clean",
3167                                   ) {
3168                if ($do->{$nosayer}) {
3169                    my $selfid = $self->pretty_id;
3170                    my $did = $do->pretty_id;
3171                    if (UNIVERSAL::can($do->{$nosayer},"failed") ?
3172                        $do->{$nosayer}->failed :
3173                        $do->{$nosayer} =~ /^NO/) {
3174                        if ($nosayer eq "make_test"
3175                            &&
3176                            $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
3177                           ) {
3178                            next NOSAYER;
3179                        }
3180                        ### XXX  don't complain about missing optional deps -- xdg, 2012-04-01
3181                        if ($self->is_locally_optional($prereq_pm, $need_module)) {
3182                            # don't complain about failing optional prereqs
3183                        }
3184                        else {
3185                            $CPAN::Frontend->mywarn("Warning: Prerequisite ".
3186                                                    "'$need_module => $need_version' ".
3187                                                    "for '$selfid' failed when ".
3188                                                    "processing '$did' with ".
3189                                                    "'$nosayer => $do->{$nosayer}'. Continuing, ".
3190                                                    "but chances to succeed are limited.\n"
3191                                                );
3192                            $CPAN::Frontend->mysleep($sponsoring/10);
3193                        }
3194                        next NEED;
3195                    } else { # the other guy succeeded
3196                        if ($nosayer =~ /^(install|make_test)$/) {
3197                            # we had this with
3198                            # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
3199                            # in 2007-03 for 'make install'
3200                            # and 2008-04: #30464 (for 'make test')
3201                            # $CPAN::Frontend->mywarn("Warning: Prerequisite ".
3202                            #                         "'$need_module => $need_version' ".
3203                            #                         "for '$selfid' already built ".
3204                            #                         "but the result looks suspicious. ".
3205                            #                         "Skipping another build attempt, ".
3206                            #                         "to prevent looping endlessly.\n"
3207                            #                        );
3208                            next NEED;
3209                        }
3210                    }
3211                }
3212            }
3213        }
3214        my $needed_as;
3215        if (0) {
3216        } elsif (exists $prereq_pm->{requires}{$need_module}
3217            || exists $prereq_pm->{opt_requires}{$need_module}
3218        ) {
3219            $needed_as = "r";
3220        } elsif ($slot eq "configure_requires_later") {
3221            # in ae872487d5 we said: C< we have not yet run the
3222            # {Build,Makefile}.PL, we must presume "r" >; but the
3223            # meta.yml standard says C< These dependencies are not
3224            # required after the distribution is installed. >; so now
3225            # we change it back to "b" and care for the proper
3226            # promotion later.
3227            $needed_as = "b";
3228        } else {
3229            $needed_as = "b";
3230        }
3231        # here need to flag as optional for recommends/suggests
3232        # -- xdg, 2012-04-01
3233        $self->debug(sprintf "%s manadory?[%s]",
3234                     $self->pretty_id,
3235                     $self->{mandatory})
3236            if $CPAN::DEBUG;
3237        my $optional = !$self->{mandatory}
3238            || $self->is_locally_optional($prereq_pm, $need_module);
3239        push @need, [$need_module,$needed_as,$optional];
3240    }
3241    my @unfolded = map { "[".join(",",@$_)."]" } @need;
3242    CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
3243    @need;
3244}
3245
3246sub _fulfills_all_version_rqs {
3247    my($self,$need_module,$available_file,$available_version,$need_version) = @_;
3248    my(@all_requirements) = split /\s*,\s*/, $need_version;
3249    local($^W) = 0;
3250    my $ok = 0;
3251  RQ: for my $rq (@all_requirements) {
3252        if ($rq =~ s|>=\s*||) {
3253        } elsif ($rq =~ s|>\s*||) {
3254            # 2005-12: one user
3255            if (CPAN::Version->vgt($available_version,$rq)) {
3256                $ok++;
3257            }
3258            next RQ;
3259        } elsif ($rq =~ s|!=\s*||) {
3260            # 2005-12: no user
3261            if (CPAN::Version->vcmp($available_version,$rq)) {
3262                $ok++;
3263                next RQ;
3264            } else {
3265                $ok=0;
3266                last RQ;
3267            }
3268        } elsif ($rq =~ m|<=?\s*|) {
3269            # 2005-12: no user
3270            $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
3271            $ok++;
3272            next RQ;
3273        } elsif ($rq =~ s|==\s*||) {
3274            # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz
3275            if (CPAN::Version->vcmp($available_version,$rq)) {
3276                $ok=0;
3277                last RQ;
3278            } else {
3279                $ok++;
3280                next RQ;
3281            }
3282        }
3283        if (! CPAN::Version->vgt($rq, $available_version)) {
3284            $ok++;
3285        }
3286        CPAN->debug(sprintf("need_module[%s]available_file[%s]".
3287                            "available_version[%s]rq[%s]ok[%d]",
3288                            $need_module,
3289                            $available_file,
3290                            $available_version,
3291                            CPAN::Version->readable($rq),
3292                            $ok,
3293                           )) if $CPAN::DEBUG;
3294    }
3295    my $ret = $ok == @all_requirements;
3296    CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG;
3297    return $ret;
3298}
3299
3300#-> sub CPAN::Distribution::read_meta
3301# read any sort of meta files, return CPAN::Meta object if no errors
3302sub read_meta {
3303    my($self) = @_;
3304    my $meta_file = $self->pick_meta_file
3305        or return;
3306
3307    return unless $CPAN::META->has_usable("CPAN::Meta");
3308    my $meta = eval { CPAN::Meta->load_file($meta_file)}
3309        or return;
3310
3311    # Very old EU::MM could have wrong META
3312    if ($meta_file eq 'META.yml'
3313        && $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/
3314    ) {
3315        my $eummv = do { local $^W = 0; $1+0; };
3316        return if $eummv < 6.2501;
3317    }
3318
3319    return $meta;
3320}
3321
3322#-> sub CPAN::Distribution::read_yaml ;
3323# XXX This should be DEPRECATED -- dagolden, 2011-02-05
3324sub read_yaml {
3325    my($self) = @_;
3326    my $meta_file = $self->pick_meta_file('\.yml$');
3327    $self->debug("meta_file[$meta_file]") if $CPAN::DEBUG;
3328    return unless $meta_file;
3329    my $yaml;
3330    eval { $yaml = $self->parse_meta_yml($meta_file) };
3331    if ($@ or ! $yaml) {
3332        return undef; # if we die, then we cannot read YAML's own META.yml
3333    }
3334    # not "authoritative"
3335    if (defined $yaml && (! ref $yaml || ref $yaml ne "HASH")) {
3336        $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
3337        $yaml = undef;
3338    }
3339    $self->debug(sprintf "yaml[%s]", $yaml || "UNDEF")
3340        if $CPAN::DEBUG;
3341    $self->debug($yaml) if $CPAN::DEBUG && $yaml;
3342    # MYMETA.yml is static and authoritative by definition
3343    if ( $meta_file =~ /MYMETA\.yml/ ) {
3344      return $yaml;
3345    }
3346    # META.yml is authoritative only if dynamic_config is defined and false
3347    if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
3348      return $yaml;
3349    }
3350    # otherwise, we can't use what we found
3351    return undef;
3352}
3353
3354#-> sub CPAN::Distribution::configure_requires ;
3355sub configure_requires {
3356    my($self) = @_;
3357    return unless my $meta_file = $self->pick_meta_file('^META');
3358    if (my $meta_obj = $self->read_meta) {
3359        my $prereqs = $meta_obj->effective_prereqs;
3360        my $cr = $prereqs->requirements_for(qw/configure requires/);
3361        return $cr ? $cr->as_string_hash : undef;
3362    }
3363    else {
3364        my $yaml = eval { $self->parse_meta_yml($meta_file) };
3365        return $yaml->{configure_requires};
3366    }
3367}
3368
3369#-> sub CPAN::Distribution::prereq_pm ;
3370sub prereq_pm {
3371    my($self) = @_;
3372    return unless $self->{writemakefile}  # no need to have succeeded
3373                                          # but we must have run it
3374        || $self->{modulebuild};
3375    unless ($self->{build_dir}) {
3376        return;
3377    }
3378    # no Makefile/Build means configuration aborted, so don't look for prereqs
3379    my $makefile  = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'descrip.mms' : 'Makefile');
3380    my $buildfile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'Build.com' : 'Build');
3381    return unless   -f $makefile || -f $buildfile;
3382    CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
3383                $self->{writemakefile}||"",
3384                $self->{modulebuild}||"",
3385               ) if $CPAN::DEBUG;
3386    my($req,$breq, $opt_req, $opt_breq);
3387    my $meta_obj = $self->read_meta;
3388    # META/MYMETA is only authoritative if dynamic_config is false
3389    if ($meta_obj && ! $meta_obj->dynamic_config) {
3390        my $prereqs = $meta_obj->effective_prereqs;
3391        my $requires = $prereqs->requirements_for(qw/runtime requires/);
3392        my $build_requires = $prereqs->requirements_for(qw/build requires/);
3393        my $test_requires = $prereqs->requirements_for(qw/test requires/);
3394        # XXX we don't yet distinguish build vs test, so merge them for now
3395        $build_requires->add_requirements($test_requires);
3396        $req = $requires->as_string_hash;
3397        $breq = $build_requires->as_string_hash;
3398
3399        # XXX assemble optional_req && optional_breq from recommends/suggests
3400        # depending on corresponding policies -- xdg, 2012-04-01
3401        CPAN->use_inst("CPAN::Meta::Requirements");
3402        my $opt_runtime = CPAN::Meta::Requirements->new;
3403        my $opt_build   = CPAN::Meta::Requirements->new;
3404        if ( $CPAN::Config->{recommends_policy} ) {
3405            $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime recommends/));
3406            $opt_build->add_requirements(   $prereqs->requirements_for(qw/build recommends/));
3407            $opt_build->add_requirements(   $prereqs->requirements_for(qw/test  recommends/));
3408
3409        }
3410        if ( $CPAN::Config->{suggests_policy} ) {
3411            $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime suggests/));
3412            $opt_build->add_requirements(   $prereqs->requirements_for(qw/build suggests/));
3413            $opt_build->add_requirements(   $prereqs->requirements_for(qw/test  suggests/));
3414        }
3415        $opt_req = $opt_runtime->as_string_hash;
3416        $opt_breq = $opt_build->as_string_hash;
3417    }
3418    elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
3419        $req =  $yaml->{requires} || {};
3420        $breq =  $yaml->{build_requires} || {};
3421        if ( $CPAN::Config->{recommends_policy} ) {
3422            $opt_req = $yaml->{recommends} || {};
3423        }
3424        undef $req unless ref $req eq "HASH" && %$req;
3425        if ($req) {
3426            if ($yaml->{generated_by} &&
3427                $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
3428                my $eummv = do { local $^W = 0; $1+0; };
3429                if ($eummv < 6.2501) {
3430                    # thanks to Slaven for digging that out: MM before
3431                    # that could be wrong because it could reflect a
3432                    # previous release
3433                    undef $req;
3434                }
3435            }
3436            my $areq;
3437            my $do_replace;
3438            foreach my $k (sort keys %{$req||{}}) {
3439                my $v = $req->{$k};
3440                next unless defined $v;
3441                if ($v =~ /\d/) {
3442                    $areq->{$k} = $v;
3443                } elsif ($k =~ /[A-Za-z]/ &&
3444                         $v =~ /[A-Za-z]/ &&
3445                         $CPAN::META->exists("CPAN::Module",$v)
3446                        ) {
3447                    $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
3448                                            "requires hash: $k => $v; I'll take both ".
3449                                            "key and value as a module name\n");
3450                    $CPAN::Frontend->mysleep(1);
3451                    $areq->{$k} = 0;
3452                    $areq->{$v} = 0;
3453                    $do_replace++;
3454                }
3455            }
3456            $req = $areq if $do_replace;
3457        }
3458    }
3459    else {
3460        $CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ".
3461                                    "methods to determine prerequisites\n");
3462    }
3463
3464    unless ($req || $breq) {
3465        my $build_dir;
3466        unless ( $build_dir = $self->{build_dir} ) {
3467            return;
3468        }
3469        my $makefile = File::Spec->catfile($build_dir,"Makefile");
3470        my $fh;
3471        if (-f $makefile
3472            and
3473            $fh = FileHandle->new("<$makefile\0")) {
3474            CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
3475            local($/) = "\n";
3476            while (<$fh>) {
3477                last if /MakeMaker post_initialize section/;
3478                my($p) = m{^[\#]
3479                           \s+PREREQ_PM\s+=>\s+(.+)
3480                       }x;
3481                next unless $p;
3482                # warn "Found prereq expr[$p]";
3483
3484                #  Regexp modified by A.Speer to remember actual version of file
3485                #  PREREQ_PM hash key wants, then add to
3486                while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
3487                    my($m,$n) = ($1,$2);
3488                    # When a prereq is mentioned twice: let the bigger
3489                    # win; usual culprit is that they declared
3490                    # build_requires separately from requires; see
3491                    # rt.cpan.org #47774
3492                    my($prevn);
3493                    if ( defined $req->{$m} ) {
3494                        $prevn = $req->{$m};
3495                    }
3496                    if ($n =~ /^q\[(.*?)\]$/) {
3497                        $n = $1;
3498                    }
3499                    if (!$prevn || CPAN::Version->vlt($prevn, $n)){
3500                        $req->{$m} = $n;
3501                    }
3502                }
3503                last;
3504            }
3505        }
3506    }
3507    unless ($req || $breq) {
3508        my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
3509        my $buildfile = File::Spec->catfile($build_dir,"Build");
3510        if (-f $buildfile) {
3511            CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
3512            my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
3513            if (-f $build_prereqs) {
3514                CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
3515                my $content = do { local *FH;
3516                                   open FH, $build_prereqs
3517                                       or $CPAN::Frontend->mydie("Could not open ".
3518                                                                 "'$build_prereqs': $!");
3519                                   local $/;
3520                                   <FH>;
3521                               };
3522                my $bphash = eval $content;
3523                if ($@) {
3524                } else {
3525                    $req  = $bphash->{requires} || +{};
3526                    $breq = $bphash->{build_requires} || +{};
3527                }
3528            }
3529        }
3530    }
3531    # XXX needs to be adapted for optional_req & optional_breq -- xdg, 2012-04-01
3532    if ($req || $breq || $opt_req || $opt_breq ) {
3533        return $self->{prereq_pm} = {
3534           requires => $req,
3535           build_requires => $breq,
3536           opt_requires => $opt_req,
3537           opt_build_requires => $opt_breq,
3538       };
3539    }
3540}
3541
3542#-> sub CPAN::Distribution::shortcut_test ;
3543# return values: undef means don't shortcut; 0 means shortcut as fail;
3544# and 1 means shortcut as success
3545sub shortcut_test {
3546    my ($self) = @_;
3547
3548    $self->debug("checking badtestcnt[$self->{ID}]") if $CPAN::DEBUG;
3549    $self->{badtestcnt} ||= 0;
3550    if ($self->{badtestcnt} > 0) {
3551        require Data::Dumper;
3552        CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
3553        return $self->goodbye("Won't repeat unsuccessful test during this command");
3554    }
3555
3556    for my $slot ( qw/later configure_requires_later/ ) {
3557        $self->debug("checking $slot slot[$self->{ID}]") if $CPAN::DEBUG;
3558        return $self->success($self->{$slot})
3559        if $self->{$slot};
3560    }
3561
3562    $self->debug("checking if tests passed[$self->{ID}]") if $CPAN::DEBUG;
3563    if ( $self->{make_test} ) {
3564        if (
3565            UNIVERSAL::can($self->{make_test},"failed") ?
3566            $self->{make_test}->failed :
3567            $self->{make_test} =~ /^NO/
3568        ) {
3569            if (
3570                UNIVERSAL::can($self->{make_test},"commandid")
3571                &&
3572                $self->{make_test}->commandid == $CPAN::CurrentCommandId
3573            ) {
3574                return $self->goodbye("Has already been tested within this command");
3575            }
3576        } else {
3577            # if global "is_tested" has been cleared, we need to mark this to
3578            # be added to PERL5LIB if not already installed
3579            if ($self->tested_ok_but_not_installed) {
3580                $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
3581            }
3582            return $self->success("Has already been tested successfully");
3583        }
3584    }
3585
3586    if ($self->{notest}) {
3587        $self->{make_test} = CPAN::Distrostatus->new("YES");
3588        return $self->success("Skipping test because of notest pragma");
3589    }
3590
3591    return undef; # no shortcut
3592}
3593
3594#-> sub CPAN::Distribution::_exe_files ;
3595sub _exe_files {
3596    my($self) = @_;
3597    return unless $self->{writemakefile}  # no need to have succeeded
3598                                          # but we must have run it
3599        || $self->{modulebuild};
3600    unless ($self->{build_dir}) {
3601        return;
3602    }
3603    CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
3604                $self->{writemakefile}||"",
3605                $self->{modulebuild}||"",
3606               ) if $CPAN::DEBUG;
3607    my $build_dir;
3608    unless ( $build_dir = $self->{build_dir} ) {
3609        return;
3610    }
3611    my $makefile = File::Spec->catfile($build_dir,"Makefile");
3612    my $fh;
3613    my @exe_files;
3614    if (-f $makefile
3615        and
3616        $fh = FileHandle->new("<$makefile\0")) {
3617        CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
3618        local($/) = "\n";
3619        while (<$fh>) {
3620            last if /MakeMaker post_initialize section/;
3621            my($p) = m{^[\#]
3622                       \s+EXE_FILES\s+=>\s+\[(.+)\]
3623                  }x;
3624            next unless $p;
3625            # warn "Found exefiles expr[$p]";
3626            my @p = split /,\s*/, $p;
3627            for my $p2 (@p) {
3628                if ($p2 =~ /^q\[(.+)\]/) {
3629                    push @exe_files, $1;
3630                }
3631            }
3632        }
3633    }
3634    return \@exe_files if @exe_files;
3635    my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
3636    if (-f $buildparams) {
3637        CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
3638        my $x = do $buildparams;
3639        for my $sf ($x->[2]{script_files}) {
3640            if (my $reftype = ref $sf) {
3641                if ($reftype eq "ARRAY") {
3642                    push @exe_files, @$sf;
3643                }
3644                elsif ($reftype eq "HASH") {
3645                    push @exe_files, keys %$sf;
3646                }
3647                else {
3648                    $CPAN::Frontend->mywarn("Invalid reftype $reftype for Build.PL 'script_files'\n");
3649                }
3650            }
3651            elsif (defined $sf) {
3652                push @exe_files, $sf;
3653            }
3654        }
3655    }
3656    return \@exe_files;
3657}
3658
3659#-> sub CPAN::Distribution::test ;
3660sub test {
3661    my($self) = @_;
3662
3663    $self->pre_test();
3664
3665    if (exists $self->{cleanup_after_install_done}) {
3666        $self->post_test();
3667        return $self->make;
3668    }
3669
3670    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
3671    if (my $goto = $self->prefs->{goto}) {
3672        $self->post_test();
3673        return $self->goto($goto);
3674    }
3675
3676    unless ($self->make){
3677        $self->post_test();
3678        return;
3679    }
3680
3681    if ( defined( my $sc = $self->shortcut_test ) ) {
3682        $self->post_test();
3683        return $sc;
3684    }
3685
3686    if ($CPAN::Signal) {
3687        delete $self->{force_update};
3688        $self->post_test();
3689        return;
3690    }
3691    # warn "XDEBUG: checking for notest: $self->{notest} $self";
3692    my $make = $self->{modulebuild} ? "Build" : "make";
3693
3694    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
3695                           ? $ENV{PERL5LIB}
3696                           : ($ENV{PERLLIB} || "");
3697
3698    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
3699    local $ENV{PERL_USE_UNSAFE_INC} =
3700        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
3701        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
3702    $CPAN::META->set_perl5lib;
3703    local $ENV{MAKEFLAGS}; # protect us from outer make calls
3704    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
3705    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
3706
3707    if ($run_allow_installing_within_test) {
3708        my($allow_installing, $why) = $self->_allow_installing;
3709        if (! $allow_installing) {
3710            $CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n");
3711            $self->introduce_myself;
3712            $self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why");
3713            $CPAN::Frontend->mywarn("  [testing] -- NOT OK\n");
3714            delete $self->{force_update};
3715            $self->post_test();
3716            return;
3717        }
3718    }
3719    $CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id);
3720
3721    my $builddir = $self->dir or
3722        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
3723
3724    unless (chdir $builddir) {
3725        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
3726        $self->post_test();
3727        return;
3728    }
3729
3730    $self->debug("Changed directory to $self->{build_dir}")
3731        if $CPAN::DEBUG;
3732
3733    if ($^O eq 'MacOS') {
3734        Mac::BuildTools::make_test($self);
3735        $self->post_test();
3736        return;
3737    }
3738
3739    if ($self->{modulebuild}) {
3740        my $thm = CPAN::Shell->expand("Module","Test::Harness");
3741        my $v = $thm->inst_version;
3742        if (CPAN::Version->vlt($v,2.62)) {
3743            # XXX Eric Wilhelm reported this as a bug: klapperl:
3744            # Test::Harness 3.0 self-tests, so that should be 'unless
3745            # installing Test::Harness'
3746            unless ($self->id eq $thm->distribution->id) {
3747                $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
3748  '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
3749                $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
3750                $self->post_test();
3751                return;
3752            }
3753        }
3754    }
3755
3756    if ( ! $self->{force_update}  ) {
3757        # bypass actual tests if "trust_test_report_history" and have a report
3758        my $have_tested_fcn;
3759        if (   $CPAN::Config->{trust_test_report_history}
3760            && $CPAN::META->has_inst("CPAN::Reporter::History")
3761            && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
3762            if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
3763                # Do nothing if grade was DISCARD
3764                if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
3765                    $self->{make_test} = CPAN::Distrostatus->new("YES");
3766                    # if global "is_tested" has been cleared, we need to mark this to
3767                    # be added to PERL5LIB if not already installed
3768                    if ($self->tested_ok_but_not_installed) {
3769                        $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
3770                    }
3771                    $CPAN::Frontend->myprint("Found prior test report -- OK\n");
3772                    $self->post_test();
3773                    return;
3774                }
3775                elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
3776                    $self->{make_test} = CPAN::Distrostatus->new("NO");
3777                    $self->{badtestcnt}++;
3778                    $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
3779                    $self->post_test();
3780                    return;
3781                }
3782            }
3783        }
3784    }
3785
3786    my $system;
3787    my $prefs_test = $self->prefs->{test};
3788    if (my $commandline
3789        = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
3790        $system = $commandline;
3791        $ENV{PERL} = CPAN::find_perl();
3792    } elsif ($self->{modulebuild}) {
3793        $system = sprintf "%s test", $self->_build_command();
3794        unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
3795            my $id = $self->pretty_id;
3796            $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
3797        }
3798    } else {
3799        $system = join " ", $self->_make_command(), "test";
3800    }
3801    my $make_test_arg = $self->_make_phase_arg("test");
3802    $system = sprintf("%s%s",
3803                      $system,
3804                      $make_test_arg ? " $make_test_arg" : "",
3805                     );
3806    my($tests_ok);
3807    my $test_env;
3808    if ($self->prefs->{test}) {
3809        $test_env = $self->prefs->{test}{env};
3810    }
3811    local @ENV{keys %$test_env} = values %$test_env if $test_env;
3812    my $expect_model = $self->_prefs_with_expect("test");
3813    my $want_expect = 0;
3814    if ( $expect_model && @{$expect_model->{talk}} ) {
3815        my $can_expect = $CPAN::META->has_inst("Expect");
3816        if ($can_expect) {
3817            $want_expect = 1;
3818        } else {
3819            $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
3820                                    "testing without\n");
3821        }
3822    }
3823
3824 FORK: {
3825        my $pid = fork;
3826        if (! defined $pid) { # contention
3827            warn "Contention '$!', sleeping 2";
3828            sleep 2;
3829            redo FORK;
3830        } elsif ($pid) { # parent
3831            if ($^O eq "MSWin32") {
3832                wait;
3833            } else {
3834            SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
3835                    if ($CPAN::Signal) {
3836                        kill 9, -$pid;
3837                    }
3838                    sleep 1;
3839                }
3840            }
3841            $tests_ok = !$?;
3842        } else { # child
3843            POSIX::setsid() unless $^O eq "MSWin32";
3844            my $c_ok;
3845            $|=1;
3846            if ($want_expect) {
3847                if ($self->_should_report('test')) {
3848                    $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
3849                        "not supported when distroprefs specify ".
3850                        "an interactive test\n");
3851                }
3852                $c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
3853            } elsif ( $self->_should_report('test') ) {
3854                $c_ok = CPAN::Reporter::test($self, $system);
3855            } else {
3856                $c_ok = system($system) == 0;
3857            }
3858            exit !$c_ok;
3859        }
3860    } # FORK
3861
3862    $self->introduce_myself;
3863    my $but = $self->_make_test_illuminate_prereqs();
3864    if ( $tests_ok ) {
3865        if ($but) {
3866            $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
3867            $self->{make_test} = CPAN::Distrostatus->new("NO $but");
3868            $self->store_persistent_state;
3869            $self->post_test();
3870            return $self->goodbye("[dependencies] -- NA");
3871        }
3872        $CPAN::Frontend->myprint("  $system -- OK\n");
3873        $self->{make_test} = CPAN::Distrostatus->new("YES");
3874        $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
3875        # probably impossible to need the next line because badtestcnt
3876        # has a lifespan of one command
3877        delete $self->{badtestcnt};
3878    } else {
3879        if ($but) {
3880            $but .= "; additionally test harness failed";
3881            $CPAN::Frontend->mywarn("$but\n");
3882            $self->{make_test} = CPAN::Distrostatus->new("NO $but");
3883        } elsif ( $self->{force_update} ) {
3884            $self->{make_test} = CPAN::Distrostatus->new(
3885                "NO but failure ignored because 'force' in effect"
3886            );
3887        } elsif ($CPAN::Signal) {
3888            $self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted");
3889        } else {
3890            $self->{make_test} = CPAN::Distrostatus->new("NO");
3891        }
3892        $self->{badtestcnt}++;
3893        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
3894        CPAN::Shell->optprint
3895              ("hint",
3896               sprintf
3897               ("//hint// to see the cpan-testers results for installing this module, try:
3898  reports %s\n",
3899                $self->pretty_id));
3900    }
3901    $self->store_persistent_state;
3902
3903    $self->post_test();
3904
3905    return $self->{force_update} ? 1 : !! $tests_ok;
3906}
3907
3908sub _make_test_illuminate_prereqs {
3909    my($self) = @_;
3910    my @prereq;
3911
3912    # local $CPAN::DEBUG = 16; # Distribution
3913    for my $m (sort keys %{$self->{sponsored_mods}}) {
3914        next unless $self->{sponsored_mods}{$m} > 0;
3915        my $m_obj = CPAN::Shell->expand("Module",$m) or next;
3916        # XXX we need available_version which reflects
3917        # $ENV{PERL5LIB} so that already tested but not yet
3918        # installed modules are counted.
3919        my $available_version = $m_obj->available_version;
3920        my $available_file = $m_obj->available_file;
3921        if ($available_version &&
3922            !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
3923           ) {
3924            CPAN->debug("m[$m] good enough available_version[$available_version]")
3925                if $CPAN::DEBUG;
3926        } elsif ($available_file
3927                 && (
3928                     !$self->{prereq_pm}{$m}
3929                     ||
3930                     $self->{prereq_pm}{$m} == 0
3931                    )
3932                ) {
3933            # lex Class::Accessor::Chained::Fast which has no $VERSION
3934            CPAN->debug("m[$m] have available_file[$available_file]")
3935                if $CPAN::DEBUG;
3936        } else {
3937            push @prereq, $m
3938                unless $self->is_locally_optional(undef, $m);
3939        }
3940    }
3941    my $but;
3942    if (@prereq) {
3943        my $cnt = @prereq;
3944        my $which = join ",", @prereq;
3945        $but = $cnt == 1 ? "one dependency not OK ($which)" :
3946            "$cnt dependencies missing ($which)";
3947    }
3948    $but;
3949}
3950
3951sub _prefs_with_expect {
3952    my($self,$where) = @_;
3953    return unless my $prefs = $self->prefs;
3954    return unless my $where_prefs = $prefs->{$where};
3955    if ($where_prefs->{expect}) {
3956        return {
3957                mode => "deterministic",
3958                timeout => 15,
3959                talk => $where_prefs->{expect},
3960               };
3961    } elsif ($where_prefs->{"eexpect"}) {
3962        return $where_prefs->{"eexpect"};
3963    }
3964    return;
3965}
3966
3967#-> sub CPAN::Distribution::clean ;
3968sub clean {
3969    my($self) = @_;
3970    my $make = $self->{modulebuild} ? "Build" : "make";
3971    $CPAN::Frontend->myprint(sprintf "Running %s clean for %s\n", $make, $self->pretty_id);
3972    unless (exists $self->{archived}) {
3973        $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
3974                                "/untarred, nothing done\n");
3975        return 1;
3976    }
3977    unless (exists $self->{build_dir}) {
3978        $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
3979        return 1;
3980    }
3981    if (exists $self->{writemakefile}
3982        and $self->{writemakefile}->failed
3983       ) {
3984        $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
3985        return 1;
3986    }
3987  EXCUSE: {
3988        my @e;
3989        exists $self->{make_clean} and $self->{make_clean} eq "YES" and
3990            push @e, "make clean already called once";
3991        $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3992    }
3993    chdir "$self->{build_dir}" or
3994        Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
3995    $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
3996
3997    if ($^O eq 'MacOS') {
3998        Mac::BuildTools::make_clean($self);
3999        return;
4000    }
4001
4002    my $system;
4003    if ($self->{modulebuild}) {
4004        unless (-f "Build") {
4005            my $cwd = CPAN::anycwd();
4006            $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
4007                                    " in cwd[$cwd]. Danger, Will Robinson!");
4008            $CPAN::Frontend->mysleep(5);
4009        }
4010        $system = sprintf "%s clean", $self->_build_command();
4011    } else {
4012        $system  = join " ", $self->_make_command(), "clean";
4013    }
4014    my $system_ok = system($system) == 0;
4015    $self->introduce_myself;
4016    if ( $system_ok ) {
4017      $CPAN::Frontend->myprint("  $system -- OK\n");
4018
4019      # $self->force;
4020
4021      # Jost Krieger pointed out that this "force" was wrong because
4022      # it has the effect that the next "install" on this distribution
4023      # will untar everything again. Instead we should bring the
4024      # object's state back to where it is after untarring.
4025
4026      for my $k (qw(
4027                    force_update
4028                    install
4029                    writemakefile
4030                    make
4031                    make_test
4032                   )) {
4033          delete $self->{$k};
4034      }
4035      $self->{make_clean} = CPAN::Distrostatus->new("YES");
4036
4037    } else {
4038      # Hmmm, what to do if make clean failed?
4039
4040      $self->{make_clean} = CPAN::Distrostatus->new("NO");
4041      $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
4042
4043      # 2006-02-27: seems silly to me to force a make now
4044      # $self->force("make"); # so that this directory won't be used again
4045
4046    }
4047    $self->store_persistent_state;
4048}
4049
4050#-> sub CPAN::Distribution::check_disabled ;
4051sub check_disabled {
4052    my ($self) = @_;
4053    $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
4054    if ($self->prefs->{disabled} && ! $self->{force_update}) {
4055        return sprintf(
4056                            "Disabled via prefs file '%s' doc %d",
4057                            $self->{prefs_file},
4058                            $self->{prefs_file_doc},
4059                            );
4060    }
4061    return;
4062}
4063
4064#-> sub CPAN::Distribution::goto ;
4065sub goto {
4066    my($self,$goto) = @_;
4067    $goto = $self->normalize($goto);
4068    my $why = sprintf(
4069                      "Goto '$goto' via prefs file '%s' doc %d",
4070                      $self->{prefs_file},
4071                      $self->{prefs_file_doc},
4072                     );
4073    $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
4074    # 2007-07-16 akoenig : Better than NA would be if we could inherit
4075    # the status of the $goto distro but given the exceptional nature
4076    # of 'goto' I feel reluctant to implement it
4077    my $goodbye_message = "[goto] -- NA $why";
4078    $self->goodbye($goodbye_message);
4079
4080    # inject into the queue
4081
4082    CPAN::Queue->delete($self->id);
4083    CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
4084
4085    # and run where we left off
4086
4087    my($method) = (caller(1))[3];
4088    my $goto_do = CPAN->instance("CPAN::Distribution",$goto);
4089    $goto_do->called_for($self->called_for) unless $goto_do->called_for;
4090    $goto_do->{mandatory} ||= $self->{mandatory};
4091    $goto_do->{reqtype}   ||= $self->{reqtype};
4092    $goto_do->{coming_from} = $self->pretty_id;
4093    $goto_do->$method();
4094    CPAN::Queue->delete_first($goto);
4095    # XXX delete_first returns undef; is that what this should return
4096    # up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
4097}
4098
4099#-> sub CPAN::Distribution::shortcut_install ;
4100# return values: undef means don't shortcut; 0 means shortcut as fail;
4101# and 1 means shortcut as success
4102sub shortcut_install {
4103    my ($self) = @_;
4104
4105    $self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
4106    if (exists $self->{install}) {
4107        my $text = UNIVERSAL::can($self->{install},"text") ?
4108            $self->{install}->text :
4109                $self->{install};
4110        if ($text =~ /^YES/) {
4111            $CPAN::META->is_installed($self->{build_dir});
4112            return $self->success("Already done");
4113        } elsif ($text =~ /is only/) {
4114            # e.g. 'is only build_requires': may be overruled later
4115            return $self->goodbye($text);
4116        } else {
4117            # comment in Todo on 2006-02-11; maybe retry?
4118            return $self->goodbye("Already tried without success");
4119        }
4120    }
4121
4122    for my $slot ( qw/later configure_requires_later/ ) {
4123        return $self->success($self->{$slot})
4124        if $self->{$slot};
4125    }
4126
4127    return undef;
4128}
4129
4130#-> sub CPAN::Distribution::is_being_sponsored ;
4131
4132# returns true if we find a distro object in the queue that has
4133# sponsored this one
4134sub is_being_sponsored {
4135    my($self) = @_;
4136    my $iterator = CPAN::Queue->iterator;
4137 QITEM: while (my $q = $iterator->()) {
4138        my $s = $q->as_string;
4139        my $obj = CPAN::Shell->expandany($s) or next QITEM;
4140        my $type = ref $obj;
4141        if ( $type eq 'CPAN::Distribution' ){
4142            for my $module (sort keys %{$obj->{sponsored_mods} || {}}) {
4143                return 1 if grep { $_ eq $module } $self->containsmods;
4144            }
4145        }
4146    }
4147    return 0;
4148}
4149
4150#-> sub CPAN::Distribution::install ;
4151sub install {
4152    my($self) = @_;
4153
4154    $self->pre_install();
4155
4156    if (exists $self->{cleanup_after_install_done}) {
4157        return $self->test;
4158    }
4159
4160    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
4161    if (my $goto = $self->prefs->{goto}) {
4162        $self->goto($goto);
4163        $self->post_install();
4164        return;
4165    }
4166
4167    unless ($self->test) {
4168        $self->post_install();
4169        return;
4170    }
4171
4172    if ( defined( my $sc = $self->shortcut_install ) ) {
4173        $self->post_install();
4174        return $sc;
4175    }
4176
4177    if ($CPAN::Signal) {
4178        delete $self->{force_update};
4179        $self->post_install();
4180        return;
4181    }
4182
4183    my $builddir = $self->dir or
4184        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
4185
4186    unless (chdir $builddir) {
4187        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
4188        $self->post_install();
4189        return;
4190    }
4191
4192    $self->debug("Changed directory to $self->{build_dir}")
4193        if $CPAN::DEBUG;
4194
4195    my $make = $self->{modulebuild} ? "Build" : "make";
4196    $CPAN::Frontend->myprint(sprintf "Running %s install for %s\n", $make, $self->pretty_id);
4197
4198    if ($^O eq 'MacOS') {
4199        Mac::BuildTools::make_install($self);
4200        $self->post_install();
4201        return;
4202    }
4203
4204    my $system;
4205    if (my $commandline = $self->prefs->{install}{commandline}) {
4206        $system = $commandline;
4207        $ENV{PERL} = CPAN::find_perl();
4208    } elsif ($self->{modulebuild}) {
4209        my($mbuild_install_build_command) =
4210            exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
4211                $CPAN::Config->{mbuild_install_build_command} ?
4212                    $CPAN::Config->{mbuild_install_build_command} :
4213                        $self->_build_command();
4214        my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
4215        $system = sprintf("%s %s %s",
4216                          $mbuild_install_build_command,
4217                          $install_directive,
4218                          $CPAN::Config->{mbuild_install_arg},
4219                         );
4220    } else {
4221        my($make_install_make_command) = $self->_make_install_make_command();
4222        $system = sprintf("%s install %s",
4223                          $make_install_make_command,
4224                          $CPAN::Config->{make_install_arg},
4225                         );
4226    }
4227
4228    my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
4229    my $brip = CPAN::HandleConfig->prefs_lookup($self,
4230                                                q{build_requires_install_policy});
4231    $brip ||="ask/yes";
4232    my $id = $self->id;
4233    my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
4234    my $want_install = "yes";
4235    if ($reqtype eq "b") {
4236        if ($brip eq "no") {
4237            $want_install = "no";
4238        } elsif ($brip =~ m|^ask/(.+)|) {
4239            my $default = $1;
4240            $default = "yes" unless $default =~ /^(y|n)/i;
4241            $want_install =
4242                CPAN::Shell::colorable_makemaker_prompt
4243                      ("$id is just needed temporarily during building or testing. ".
4244                       "Do you want to install it permanently?",
4245                       $default);
4246        }
4247    }
4248    unless ($want_install =~ /^y/i) {
4249        my $is_only = "is only 'build_requires'";
4250        $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
4251        delete $self->{force_update};
4252        $self->goodbye("Not installing because $is_only");
4253        $self->post_install();
4254        return;
4255    }
4256    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
4257                           ? $ENV{PERL5LIB}
4258                           : ($ENV{PERLLIB} || "");
4259
4260    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
4261    local $ENV{PERL_USE_UNSAFE_INC} =
4262        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
4263        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
4264    $CPAN::META->set_perl5lib;
4265    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
4266    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
4267
4268    my $install_env;
4269    if ($self->prefs->{install}) {
4270        $install_env = $self->prefs->{install}{env};
4271    }
4272    local @ENV{keys %$install_env} = values %$install_env if $install_env;
4273
4274    if (! $run_allow_installing_within_test) {
4275        my($allow_installing, $why) = $self->_allow_installing;
4276        if (! $allow_installing) {
4277            $CPAN::Frontend->mywarn("Installation stopped: $why\n");
4278            $self->introduce_myself;
4279            $self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why");
4280            $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
4281            delete $self->{force_update};
4282            $self->post_install();
4283            return;
4284        }
4285    }
4286    my($pipe) = FileHandle->new("$system $stderr |");
4287    unless ($pipe) {
4288        $CPAN::Frontend->mywarn("Can't execute $system: $!");
4289        $self->introduce_myself;
4290        $self->{install} = CPAN::Distrostatus->new("NO");
4291        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
4292        delete $self->{force_update};
4293        $self->post_install();
4294        return;
4295    }
4296    my($makeout) = "";
4297    while (<$pipe>) {
4298        print $_; # intentionally NOT use Frontend->myprint because it
4299                  # looks irritating when we markup in color what we
4300                  # just pass through from an external program
4301        $makeout .= $_;
4302    }
4303    $pipe->close;
4304    my $close_ok = $? == 0;
4305    $self->introduce_myself;
4306    if ( $close_ok ) {
4307        $CPAN::Frontend->myprint("  $system -- OK\n");
4308        $CPAN::META->is_installed($self->{build_dir});
4309        $self->{install} = CPAN::Distrostatus->new("YES");
4310        if ($CPAN::Config->{'cleanup_after_install'}
4311            && ! $self->is_dot_dist
4312            && ! $self->is_being_sponsored) {
4313            my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
4314            chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
4315            File::Path::rmtree($self->{build_dir});
4316            my $yml = "$self->{build_dir}.yml";
4317            if (-e $yml) {
4318                unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
4319            }
4320            $self->{cleanup_after_install_done}=1;
4321        }
4322    } else {
4323        $self->{install} = CPAN::Distrostatus->new("NO");
4324        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
4325        my $mimc =
4326            CPAN::HandleConfig->prefs_lookup($self,
4327                                             q{make_install_make_command});
4328        if (
4329            $makeout =~ /permission/s
4330            && $> > 0
4331            && (
4332                ! $mimc
4333                || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
4334                                                              q{make}))
4335               )
4336           ) {
4337            $CPAN::Frontend->myprint(
4338                                     qq{----\n}.
4339                                     qq{  You may have to su }.
4340                                     qq{to root to install the package\n}.
4341                                     qq{  (Or you may want to run something like\n}.
4342                                     qq{    o conf make_install_make_command 'sudo make'\n}.
4343                                     qq{  to raise your permissions.}
4344                                    );
4345        }
4346    }
4347    delete $self->{force_update};
4348    unless ($CPAN::Config->{'cleanup_after_install'}) {
4349        $self->store_persistent_state;
4350    }
4351
4352    $self->post_install();
4353
4354    return !! $close_ok;
4355}
4356
4357sub blib_pm_walk {
4358    my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch");
4359    return sub {
4360    LOOP: {
4361            if (@queue) {
4362                my $file = shift @queue;
4363                if (-d $file) {
4364                    my $dh;
4365                    opendir $dh, $file or next;
4366                    my @newfiles = map {
4367                        my @ret;
4368                        my $maybedir = File::Spec->catdir($file, $_);
4369                        if (-d $maybedir) {
4370                            unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) {
4371                                # prune the blib/arch/auto directory, no pm files there
4372                                @ret = $maybedir;
4373                            }
4374                        } elsif (/\.pm$/) {
4375                            my $mustbefile = File::Spec->catfile($file, $_);
4376                            if (-f $mustbefile) {
4377                                @ret = $mustbefile;
4378                            }
4379                        }
4380                        @ret;
4381                    } grep {
4382                        $_ ne "."
4383                            && $_ ne ".."
4384                        } readdir $dh;
4385                    push @queue, @newfiles;
4386                    redo LOOP;
4387                } else {
4388                    return $file;
4389                }
4390            } else {
4391                return;
4392            }
4393        }
4394    };
4395}
4396
4397sub _allow_installing {
4398    my($self) = @_;
4399    my $id = my $pretty_id = $self->pretty_id;
4400    if ($self->{CALLED_FOR}) {
4401        $id .= " (called for $self->{CALLED_FOR})";
4402    }
4403    my $allow_down   = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades});
4404    $allow_down      ||= "ask/yes";
4405    my $allow_outdd  = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists});
4406    $allow_outdd     ||= "ask/yes";
4407    return 1 if
4408           $allow_down  eq "yes"
4409        && $allow_outdd eq "yes";
4410    if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) {
4411        return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods;
4412        if ($allow_outdd ne "yes") {
4413            $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");
4414            $allow_outdd = "yes";
4415        }
4416    }
4417    return 1 if
4418           $allow_down  eq "yes"
4419        && $allow_outdd eq "yes";
4420    my($dist_version, $dist_dist);
4421    if ($allow_outdd ne "yes"){
4422        my $dni = CPAN::DistnameInfo->new($pretty_id);
4423        $dist_version = $dni->version;
4424        $dist_dist    = $dni->dist;
4425    }
4426    my $iterator = blib_pm_walk();
4427    my(@down,@outdd);
4428    while (my $file = $iterator->()) {
4429        my $version = CPAN::Module->parse_version($file);
4430        my($volume, $directories, $pmfile) = File::Spec->splitpath( $file );
4431        my @dirs = File::Spec->splitdir( $directories );
4432        my(@blib_plus1) = splice @dirs, 0, 2;
4433        my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile);
4434        unless ($allow_down eq "yes") {
4435            if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) {
4436                my $inst_version = CPAN::Module->parse_version($inst_file);
4437                my $cmp = CPAN::Version->vcmp($version, $inst_version);
4438                if ($cmp) {
4439                    if ($cmp < 0) {
4440                        push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version };
4441                    }
4442                }
4443                if (@down) {
4444                    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}')";
4445                    if (my($default) = $allow_down =~ m|^ask/(.+)|) {
4446                        $default = "yes" unless $default =~ /^(y|n)/i;
4447                        my $answer = CPAN::Shell::colorable_makemaker_prompt
4448                                ("$why. Do you want to allow installing it?",
4449                                 $default, "colorize_warn");
4450                        $allow_down = $answer =~ /^\s*y/i ? "yes" : "no";
4451                    }
4452                    if ($allow_down eq "no") {
4453                        return (0, $why);
4454                    }
4455                }
4456            }
4457        }
4458        unless ($allow_outdd eq "yes") {
4459            my @pmpath = (@dirs, $pmfile);
4460            $pmpath[-1] =~ s/\.pm$//;
4461            my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath);
4462            if ($mo) {
4463                my $cpan_version = $mo->cpan_version;
4464                my $is_lower = CPAN::Version->vlt($version, $cpan_version);
4465                my $other_dist;
4466                if (my $mo_dist = $mo->distribution) {
4467                    $other_dist = $mo_dist->pretty_id;
4468                    my $dni = CPAN::DistnameInfo->new($other_dist);
4469                    if ($dni->dist eq $dist_dist){
4470                        if (CPAN::Version->vgt($dni->version, $dist_version)) {
4471                            push @outdd, {
4472                                pmpath       => $pmpath,
4473                                cpan_path    => $dni->pathname,
4474                                dist_version => $dni->version,
4475                                dist_dist    => $dni->dist,
4476                            };
4477                        }
4478                    }
4479                }
4480            }
4481            if (@outdd && $allow_outdd ne "yes") {
4482                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}')";
4483                if ($outdd[0]{dist_dist} eq $dist_dist) {
4484                    $why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')";
4485                }
4486                if (my($default) = $allow_outdd =~ m|^ask/(.+)|) {
4487                    $default = "yes" unless $default =~ /^(y|n)/i;
4488                    my $answer = CPAN::Shell::colorable_makemaker_prompt
4489                        ("$why. Do you want to allow installing it?",
4490                         $default, "colorize_warn");
4491                    $allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no";
4492                }
4493                if ($allow_outdd eq "no") {
4494                    return (0, $why);
4495                }
4496            }
4497        }
4498    }
4499    return 1;
4500}
4501
4502sub _file_in_path { # similar to CPAN::Module::_file_in_path
4503    my($self,$pmpath,$incpath) = @_;
4504    my($dir,@packpath);
4505    foreach $dir (@$incpath) {
4506        my $pmfile = File::Spec->catfile($dir,$pmpath);
4507        if (-f $pmfile) {
4508            return $pmfile;
4509        }
4510    }
4511    return;
4512}
4513sub introduce_myself {
4514    my($self) = @_;
4515    $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
4516}
4517
4518#-> sub CPAN::Distribution::dir ;
4519sub dir {
4520    shift->{build_dir};
4521}
4522
4523#-> sub CPAN::Distribution::perldoc ;
4524sub perldoc {
4525    my($self) = @_;
4526
4527    my($dist) = $self->id;
4528    my $package = $self->called_for;
4529
4530    if ($CPAN::META->has_inst("Pod::Perldocs")) {
4531        my($perl) = $self->perl
4532            or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
4533        my @args = ($perl, q{-MPod::Perldocs}, q{-e},
4534                    q{Pod::Perldocs->run()}, $package);
4535        my($wstatus);
4536        unless ( ($wstatus = system(@args)) == 0 ) {
4537            my $estatus = $wstatus >> 8;
4538            $CPAN::Frontend->myprint(qq{
4539    Function system("@args")
4540    returned status $estatus (wstat $wstatus)
4541    });
4542        }
4543    }
4544    else {
4545        $self->_display_url( $CPAN::Defaultdocs . $package );
4546    }
4547}
4548
4549#-> sub CPAN::Distribution::_check_binary ;
4550sub _check_binary {
4551    my ($dist,$shell,$binary) = @_;
4552    my ($pid,$out);
4553
4554    $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
4555      if $CPAN::DEBUG;
4556
4557    if ($CPAN::META->has_inst("File::Which")) {
4558        return File::Which::which($binary);
4559    } else {
4560        local *README;
4561        $pid = open README, "which $binary|"
4562            or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
4563        return unless $pid;
4564        while (<README>) {
4565            $out .= $_;
4566        }
4567        close README
4568            or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
4569                and return;
4570    }
4571
4572    $CPAN::Frontend->myprint(qq{   + $out \n})
4573      if $CPAN::DEBUG && $out;
4574
4575    return $out;
4576}
4577
4578#-> sub CPAN::Distribution::_display_url ;
4579sub _display_url {
4580    my($self,$url) = @_;
4581    my($res,$saved_file,$pid,$out);
4582
4583    $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
4584      if $CPAN::DEBUG;
4585
4586    # should we define it in the config instead?
4587    my $html_converter = "html2text.pl";
4588
4589    my $web_browser = $CPAN::Config->{'lynx'} || undef;
4590    my $web_browser_out = $web_browser
4591        ? CPAN::Distribution->_check_binary($self,$web_browser)
4592        : undef;
4593
4594    if ($web_browser_out) {
4595        # web browser found, run the action
4596        my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
4597        $CPAN::Frontend->myprint(qq{system[$browser $url]})
4598            if $CPAN::DEBUG;
4599        $CPAN::Frontend->myprint(qq{
4600Displaying URL
4601  $url
4602with browser $browser
4603});
4604        $CPAN::Frontend->mysleep(1);
4605        system("$browser $url");
4606        if ($saved_file) { 1 while unlink($saved_file) }
4607    } else {
4608        # web browser not found, let's try text only
4609        my $html_converter_out =
4610            CPAN::Distribution->_check_binary($self,$html_converter);
4611        $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
4612
4613        if ($html_converter_out ) {
4614            # html2text found, run it
4615            $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
4616            $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
4617                unless defined($saved_file);
4618
4619            local *README;
4620            $pid = open README, "$html_converter $saved_file |"
4621                or $CPAN::Frontend->mydie(qq{
4622Could not fork '$html_converter $saved_file': $!});
4623            my($fh,$filename);
4624            if ($CPAN::META->has_usable("File::Temp")) {
4625                $fh = File::Temp->new(
4626                                      dir      => File::Spec->tmpdir,
4627                                      template => 'cpan_htmlconvert_XXXX',
4628                                      suffix => '.txt',
4629                                      unlink => 0,
4630                                     );
4631                $filename = $fh->filename;
4632            } else {
4633                $filename = "cpan_htmlconvert_$$.txt";
4634                $fh = FileHandle->new();
4635                open $fh, ">$filename" or die;
4636            }
4637            while (<README>) {
4638                $fh->print($_);
4639            }
4640            close README or
4641                $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
4642            my $tmpin = $fh->filename;
4643            $CPAN::Frontend->myprint(sprintf(qq{
4644Run '%s %s' and
4645saved output to %s\n},
4646                                             $html_converter,
4647                                             $saved_file,
4648                                             $tmpin,
4649                                            )) if $CPAN::DEBUG;
4650            close $fh;
4651            local *FH;
4652            open FH, $tmpin
4653                or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
4654            my $fh_pager = FileHandle->new;
4655            local($SIG{PIPE}) = "IGNORE";
4656            my $pager = $CPAN::Config->{'pager'} || "cat";
4657            $fh_pager->open("|$pager")
4658                or $CPAN::Frontend->mydie(qq{
4659Could not open pager '$pager': $!});
4660            $CPAN::Frontend->myprint(qq{
4661Displaying URL
4662  $url
4663with pager "$pager"
4664});
4665            $CPAN::Frontend->mysleep(1);
4666            $fh_pager->print(<FH>);
4667            $fh_pager->close;
4668        } else {
4669            # coldn't find the web browser or html converter
4670            $CPAN::Frontend->myprint(qq{
4671You need to install lynx or $html_converter to use this feature.});
4672        }
4673    }
4674}
4675
4676#-> sub CPAN::Distribution::_getsave_url ;
4677sub _getsave_url {
4678    my($dist, $shell, $url) = @_;
4679
4680    $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
4681      if $CPAN::DEBUG;
4682
4683    my($fh,$filename);
4684    if ($CPAN::META->has_usable("File::Temp")) {
4685        $fh = File::Temp->new(
4686                              dir      => File::Spec->tmpdir,
4687                              template => "cpan_getsave_url_XXXX",
4688                              suffix => ".html",
4689                              unlink => 0,
4690                             );
4691        $filename = $fh->filename;
4692    } else {
4693        $fh = FileHandle->new;
4694        $filename = "cpan_getsave_url_$$.html";
4695    }
4696    my $tmpin = $filename;
4697    if ($CPAN::META->has_usable('LWP')) {
4698        $CPAN::Frontend->myprint("Fetching with LWP:
4699  $url
4700");
4701        my $Ua;
4702        CPAN::LWP::UserAgent->config;
4703        eval { $Ua = CPAN::LWP::UserAgent->new; };
4704        if ($@) {
4705            $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
4706            return;
4707        } else {
4708            my($var);
4709            $Ua->proxy('http', $var)
4710                if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4711            $Ua->no_proxy($var)
4712                if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4713        }
4714
4715        my $req = HTTP::Request->new(GET => $url);
4716        $req->header('Accept' => 'text/html');
4717        my $res = $Ua->request($req);
4718        if ($res->is_success) {
4719            $CPAN::Frontend->myprint(" + request successful.\n")
4720                if $CPAN::DEBUG;
4721            print $fh $res->content;
4722            close $fh;
4723            $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
4724                if $CPAN::DEBUG;
4725            return $tmpin;
4726        } else {
4727            $CPAN::Frontend->myprint(sprintf(
4728                                             "LWP failed with code[%s], message[%s]\n",
4729                                             $res->code,
4730                                             $res->message,
4731                                            ));
4732            return;
4733        }
4734    } else {
4735        $CPAN::Frontend->mywarn("  LWP not available\n");
4736        return;
4737    }
4738}
4739
4740#-> sub CPAN::Distribution::_build_command
4741sub _build_command {
4742    my($self) = @_;
4743    if ($^O eq "MSWin32") { # special code needed at least up to
4744                            # Module::Build 0.2611 and 0.2706; a fix
4745                            # in M:B has been promised 2006-01-30
4746        my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
4747        return "$perl ./Build";
4748    }
4749    elsif ($^O eq 'VMS') {
4750        return "$^X Build.com";
4751    }
4752    return "./Build";
4753}
4754
4755#-> sub CPAN::Distribution::_should_report
4756sub _should_report {
4757    my($self, $phase) = @_;
4758    die "_should_report() requires a 'phase' argument"
4759        if ! defined $phase;
4760
4761    return unless $CPAN::META->has_usable("CPAN::Reporter");
4762
4763    # configured
4764    my $test_report = CPAN::HandleConfig->prefs_lookup($self,
4765                                                       q{test_report});
4766    return unless $test_report;
4767
4768    # don't repeat if we cached a result
4769    return $self->{should_report}
4770        if exists $self->{should_report};
4771
4772    # don't report if we generated a Makefile.PL
4773    if ( $self->{had_no_makefile_pl} ) {
4774        $CPAN::Frontend->mywarn(
4775            "Will not send CPAN Testers report with generated Makefile.PL.\n"
4776        );
4777        return $self->{should_report} = 0;
4778    }
4779
4780    # available
4781    if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
4782        $CPAN::Frontend->mywarnonce(
4783            "CPAN::Reporter not installed.  No reports will be sent.\n"
4784        );
4785        return $self->{should_report} = 0;
4786    }
4787
4788    # capable
4789    my $crv = CPAN::Reporter->VERSION;
4790    if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
4791        # don't cache $self->{should_report} -- need to check each phase
4792        if ( $phase eq 'test' ) {
4793            return 1;
4794        }
4795        else {
4796            $CPAN::Frontend->mywarn(
4797                "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
4798                "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
4799            );
4800            return;
4801        }
4802    }
4803
4804    # appropriate
4805    if ($self->is_dot_dist) {
4806        $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
4807                                "for local directories\n");
4808        return $self->{should_report} = 0;
4809    }
4810    if ($self->prefs->{patches}
4811        &&
4812        @{$self->prefs->{patches}}
4813        &&
4814        $self->{patched}
4815       ) {
4816        $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
4817                                "when the source has been patched\n");
4818        return $self->{should_report} = 0;
4819    }
4820
4821    # proceed and cache success
4822    return $self->{should_report} = 1;
4823}
4824
4825#-> sub CPAN::Distribution::reports
4826sub reports {
4827    my($self) = @_;
4828    my $pathname = $self->id;
4829    $CPAN::Frontend->myprint("Distribution: $pathname\n");
4830
4831    unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
4832        $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
4833    }
4834    unless ($CPAN::META->has_usable("LWP")) {
4835        $CPAN::Frontend->mydie("LWP not installed; cannot continue");
4836    }
4837    unless ($CPAN::META->has_usable("File::Temp")) {
4838        $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
4839    }
4840
4841    my $format;
4842    if ($CPAN::META->has_inst("YAML::XS") || $CPAN::META->has_inst("YAML::Syck")){
4843        $format = 'yaml';
4844    }
4845    elsif (!$format && $CPAN::META->has_inst("JSON::PP") ) {
4846        $format = 'json';
4847    }
4848    else {
4849        $CPAN::Frontend->mydie("JSON::PP not installed, cannot continue");
4850    }
4851
4852    my $d = CPAN::DistnameInfo->new($pathname);
4853
4854    my $dist      = $d->dist;      # "CPAN-DistnameInfo"
4855    my $version   = $d->version;   # "0.02"
4856    my $maturity  = $d->maturity;  # "released"
4857    my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
4858    my $cpanid    = $d->cpanid;    # "GBARR"
4859    my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
4860
4861    my $url = sprintf "http://www.cpantesters.org/show/%s.%s", $dist, $format;
4862
4863    CPAN::LWP::UserAgent->config;
4864    my $Ua;
4865    eval { $Ua = CPAN::LWP::UserAgent->new; };
4866    if ($@) {
4867        $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
4868    }
4869    $CPAN::Frontend->myprint("Fetching '$url'...");
4870    my $resp = $Ua->get($url);
4871    unless ($resp->is_success) {
4872        $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
4873    }
4874    $CPAN::Frontend->myprint("DONE\n\n");
4875    my $unserialized;
4876    if ( $format eq 'yaml' ) {
4877        my $yaml = $resp->content;
4878        # what a long way round!
4879        my $fh = File::Temp->new(
4880                                 dir      => File::Spec->tmpdir,
4881                                 template => 'cpan_reports_XXXX',
4882                                 suffix => '.yaml',
4883                                 unlink => 0,
4884                                );
4885        my $tfilename = $fh->filename;
4886        print $fh $yaml;
4887        close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
4888        $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
4889        unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
4890    } else {
4891        require JSON::PP;
4892        $unserialized = JSON::PP->new->utf8->decode($resp->content);
4893    }
4894    my %other_versions;
4895    my $this_version_seen;
4896    for my $rep (@$unserialized) {
4897        my $rversion = $rep->{version};
4898        if ($rversion eq $version) {
4899            unless ($this_version_seen++) {
4900                $CPAN::Frontend->myprint ("$rep->{version}:\n");
4901            }
4902            my $arch = $rep->{archname} || $rep->{platform}        || '????';
4903            my $grade = $rep->{action}  || $rep->{status}          || '????';
4904            my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????';
4905            $CPAN::Frontend->myprint
4906                (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
4907                         $arch eq $Config::Config{archname}?"*":"",
4908                         $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"",
4909                         $grade,
4910                         $rep->{perl},
4911                         $ostext,
4912                         $rep->{osvers},
4913                         $arch,
4914                        ));
4915        } else {
4916            $other_versions{$rep->{version}}++;
4917        }
4918    }
4919    unless ($this_version_seen) {
4920        $CPAN::Frontend->myprint("No reports found for version '$version'
4921Reports for other versions:\n");
4922        for my $v (sort keys %other_versions) {
4923            $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
4924        }
4925    }
4926    $url = substr($url,0,-4) . 'html';
4927    $CPAN::Frontend->myprint("See $url for details\n");
4928}
4929
49301;
4931