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