File Coverage

blib/lib/CPAN/Distribution.pm
Criterion Covered Total %
statement 91 2196 4.1
branch 29 1446 2.0
condition 11 530 2.0
subroutine 15 111 13.5
pod 0 73 0.0
total 146 4356 3.3


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