File Coverage

blib/lib/CPAN/Distribution.pm
Criterion Covered Total %
statement 85 2162 3.9
branch 28 1416 1.9
condition 11 521 2.1
subroutine 14 109 12.8
pod 0 73 0.0
total 138 4281 3.2


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