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