File Coverage

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