File Coverage

blib/lib/CPAN/Distribution.pm
Criterion Covered Total %
statement 94 2472 3.8
branch 29 1584 1.8
condition 11 598 1.8
subroutine 16 117 13.6
pod 0 75 0.0
total 150 4846 3.1


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