← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:14 2017

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