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