File Coverage

blib/lib/CPAN/Distribution.pm
Criterion Covered Total %
statement 94 2516 3.7
branch 29 1614 1.8
condition 11 604 1.8
subroutine 16 117 13.6
pod 0 75 0.0
total 150 4926 3.0


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