File Coverage

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