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