File Coverage

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


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