File Coverage

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