This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPAN.pm to 1.93_53
[perl5.git] / lib / CPAN / Module.pm
CommitLineData
f9916dde
AK
1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2# vim: ts=4 sts=4 sw=4:
3package CPAN::Module;
4use strict;
5@CPAN::Module::ISA = qw(CPAN::InfoObj);
6
7use vars qw(
8 $VERSION
9);
10$VERSION = "5.5";
11
12# Accessors
13#-> sub CPAN::Module::userid
14sub userid {
15 my $self = shift;
16 my $ro = $self->ro;
17 return unless $ro;
18 return $ro->{userid} || $ro->{CPAN_USERID};
19}
20#-> sub CPAN::Module::description
21sub description {
22 my $self = shift;
23 my $ro = $self->ro or return "";
24 $ro->{description}
25}
26
27#-> sub CPAN::Module::distribution
28sub distribution {
29 my($self) = @_;
30 CPAN::Shell->expand("Distribution",$self->cpan_file);
31}
32
33#-> sub CPAN::Module::_is_representative_module
34sub _is_representative_module {
35 my($self) = @_;
36 return $self->{_is_representative_module} if defined $self->{_is_representative_module};
37 my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
38 $pm =~ s|.+/||;
39 $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
40 $pm =~ s|-\d+\.\d+.+$||;
41 $pm =~ s|-[\d\.]+$||;
42 $pm =~ s/-/::/g;
43 $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
44 # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
45 $self->{_is_representative_module};
46}
47
48#-> sub CPAN::Module::undelay
49sub undelay {
50 my $self = shift;
51 delete $self->{later};
52 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
53 $dist->undelay;
54 }
55}
56
57# mark as dirty/clean
58#-> sub CPAN::Module::color_cmd_tmps ;
59sub color_cmd_tmps {
60 my($self) = shift;
61 my($depth) = shift || 0;
62 my($color) = shift || 0;
63 my($ancestors) = shift || [];
64 # a module needs to recurse to its cpan_file
65
66 return if exists $self->{incommandcolor}
67 && $color==1
68 && $self->{incommandcolor}==$color;
69 return if $color==0 && !$self->{incommandcolor};
70 if ($color>=1) {
71 if ( $self->uptodate ) {
72 $self->{incommandcolor} = $color;
73 return;
74 } elsif (my $have_version = $self->available_version) {
75 # maybe what we have is good enough
76 if (@$ancestors) {
77 my $who_asked_for_me = $ancestors->[-1];
78 my $obj = CPAN::Shell->expandany($who_asked_for_me);
79 if (0) {
80 } elsif ($obj->isa("CPAN::Bundle")) {
81 # bundles cannot specify a minimum version
82 return;
83 } elsif ($obj->isa("CPAN::Distribution")) {
84 if (my $prereq_pm = $obj->prereq_pm) {
85 for my $k (keys %$prereq_pm) {
86 if (my $want_version = $prereq_pm->{$k}{$self->id}) {
87 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
88 $self->{incommandcolor} = $color;
89 return;
90 }
91 }
92 }
93 }
94 }
95 }
96 }
97 } else {
98 $self->{incommandcolor} = $color; # set me before recursion,
99 # so we can break it
100 }
101 if ($depth>=$CPAN::MAX_RECURSION) {
102 die(CPAN::Exception::RecursiveDependency->new($ancestors));
103 }
104 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
105
106 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
107 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
108 }
109 # unreached code?
110 # if ($color==0) {
111 # delete $self->{badtestcnt};
112 # }
113 $self->{incommandcolor} = $color;
114}
115
116#-> sub CPAN::Module::as_glimpse ;
117sub as_glimpse {
118 my($self) = @_;
119 my(@m);
120 my $class = ref($self);
121 $class =~ s/^CPAN:://;
122 my $color_on = "";
123 my $color_off = "";
124 if (
125 $CPAN::Shell::COLOR_REGISTERED
126 &&
127 $CPAN::META->has_inst("Term::ANSIColor")
128 &&
129 $self->description
130 ) {
131 $color_on = Term::ANSIColor::color("green");
132 $color_off = Term::ANSIColor::color("reset");
133 }
134 my $uptodateness = " ";
135 unless ($class eq "Bundle") {
136 my $u = $self->uptodate;
137 $uptodateness = $u ? "=" : "<" if defined $u;
138 };
139 my $id = do {
140 my $d = $self->distribution;
141 $d ? $d -> pretty_id : $self->cpan_userid;
142 };
143 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
144 $class,
145 $uptodateness,
146 $color_on,
147 $self->id,
148 $color_off,
149 $id,
150 );
151 join "", @m;
152}
153
154#-> sub CPAN::Module::dslip_status
155sub dslip_status {
156 my($self) = @_;
157 my($stat);
158 # development status
159 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
160 pre-alpha alpha beta released
161 mature standard,;
162 # support level
163 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
164 developer comp.lang.perl.*
165 none abandoned,;
166 # language
167 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
168 # interface
169 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
170 references+ties
171 object-oriented pragma
172 hybrid none,;
173 # public licence
174 @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
175 GPL LGPL
176 BSD Artistic Artistic_2
177 open-source
178 distribution_allowed
179 restricted_distribution
180 no_licence,;
181 for my $x (qw(d s l i p)) {
182 $stat->{$x}{' '} = 'unknown';
183 $stat->{$x}{'?'} = 'unknown';
184 }
185 my $ro = $self->ro;
186 return +{} unless $ro && $ro->{statd};
187 return {
188 D => $ro->{statd},
189 S => $ro->{stats},
190 L => $ro->{statl},
191 I => $ro->{stati},
192 P => $ro->{statp},
193 DV => $stat->{D}{$ro->{statd}},
194 SV => $stat->{S}{$ro->{stats}},
195 LV => $stat->{L}{$ro->{statl}},
196 IV => $stat->{I}{$ro->{stati}},
197 PV => $stat->{P}{$ro->{statp}},
198 };
199}
200
201#-> sub CPAN::Module::as_string ;
202sub as_string {
203 my($self) = @_;
204 my(@m);
205 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
206 my $class = ref($self);
207 $class =~ s/^CPAN:://;
208 local($^W) = 0;
209 push @m, $class, " id = $self->{ID}\n";
210 my $sprintf = " %-12s %s\n";
211 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
212 if $self->description;
213 my $sprintf2 = " %-12s %s (%s)\n";
214 my($userid);
215 $userid = $self->userid;
216 if ( $userid ) {
217 my $author;
218 if ($author = CPAN::Shell->expand('Author',$userid)) {
219 my $email = "";
220 my $m; # old perls
221 if ($m = $author->email) {
222 $email = " <$m>";
223 }
224 push @m, sprintf(
225 $sprintf2,
226 'CPAN_USERID',
227 $userid,
228 $author->fullname . $email
229 );
230 }
231 }
232 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
233 if $self->cpan_version;
234 if (my $cpan_file = $self->cpan_file) {
235 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
236 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
237 my $upload_date = $dist->upload_date;
238 if ($upload_date) {
239 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
240 }
241 }
242 }
243 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
244 my $dslip = $self->dslip_status;
245 push @m, sprintf(
246 $sprintf3,
247 'DSLIP_STATUS',
248 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
249 ) if $dslip->{D};
250 my $local_file = $self->inst_file;
251 unless ($self->{MANPAGE}) {
252 my $manpage;
253 if ($local_file) {
254 $manpage = $self->manpage_headline($local_file);
255 } else {
256 # If we have already untarred it, we should look there
257 my $dist = $CPAN::META->instance('CPAN::Distribution',
258 $self->cpan_file);
259 # warn "dist[$dist]";
260 # mff=manifest file; mfh=manifest handle
261 my($mff,$mfh);
262 if (
263 $dist->{build_dir}
264 and
265 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
266 and
267 $mfh = FileHandle->new($mff)
268 ) {
269 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
270 my $lfre = $self->id; # local file RE
271 $lfre =~ s/::/./g;
272 $lfre .= "\\.pm\$";
273 my($lfl); # local file file
274 local $/ = "\n";
275 my(@mflines) = <$mfh>;
276 for (@mflines) {
277 s/^\s+//;
278 s/\s.*//s;
279 }
280 while (length($lfre)>5 and !$lfl) {
281 ($lfl) = grep /$lfre/, @mflines;
282 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
283 $lfre =~ s/.+?\.//;
284 }
285 $lfl =~ s/\s.*//; # remove comments
286 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
287 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
288 # warn "lfl_abs[$lfl_abs]";
289 if (-f $lfl_abs) {
290 $manpage = $self->manpage_headline($lfl_abs);
291 }
292 }
293 }
294 $self->{MANPAGE} = $manpage if $manpage;
295 }
296 my($item);
297 for $item (qw/MANPAGE/) {
298 push @m, sprintf($sprintf, $item, $self->{$item})
299 if exists $self->{$item};
300 }
301 for $item (qw/CONTAINS/) {
302 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
303 if exists $self->{$item} && @{$self->{$item}};
304 }
305 push @m, sprintf($sprintf, 'INST_FILE',
306 $local_file || "(not installed)");
307 push @m, sprintf($sprintf, 'INST_VERSION',
308 $self->inst_version) if $local_file;
309 if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
310 my $available_file = $self->available_file;
311 if ($available_file && $available_file ne $local_file) {
312 push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
313 push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
314 }
315 }
316 join "", @m, "\n";
317}
318
319#-> sub CPAN::Module::manpage_headline
320sub manpage_headline {
321 my($self,$local_file) = @_;
322 my(@local_file) = $local_file;
323 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
324 push @local_file, $local_file;
325 my(@result,$locf);
326 for $locf (@local_file) {
327 next unless -f $locf;
328 my $fh = FileHandle->new($locf)
329 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
330 my $inpod = 0;
331 local $/ = "\n";
332 while (<$fh>) {
333 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
334 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
335 next unless $inpod;
336 next if /^=/;
337 next if /^\s+$/;
338 chomp;
339 push @result, $_;
340 }
341 close $fh;
342 last if @result;
343 }
344 for (@result) {
345 s/^\s+//;
346 s/\s+$//;
347 }
348 join " ", @result;
349}
350
351#-> sub CPAN::Module::cpan_file ;
352# Note: also inherited by CPAN::Bundle
353sub cpan_file {
354 my $self = shift;
355 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
356 unless ($self->ro) {
357 CPAN::Index->reload;
358 }
359 my $ro = $self->ro;
360 if ($ro && defined $ro->{CPAN_FILE}) {
361 return $ro->{CPAN_FILE};
362 } else {
363 my $userid = $self->userid;
364 if ( $userid ) {
365 if ($CPAN::META->exists("CPAN::Author",$userid)) {
366 my $author = $CPAN::META->instance("CPAN::Author",
367 $userid);
368 my $fullname = $author->fullname;
369 my $email = $author->email;
370 unless (defined $fullname && defined $email) {
371 return sprintf("Contact Author %s",
372 $userid,
373 );
374 }
375 return "Contact Author $fullname <$email>";
376 } else {
377 return "Contact Author $userid (Email address not available)";
378 }
379 } else {
380 return "N/A";
381 }
382 }
383}
384
385#-> sub CPAN::Module::cpan_version ;
386sub cpan_version {
387 my $self = shift;
388
389 my $ro = $self->ro;
390 unless ($ro) {
391 # Can happen with modules that are not on CPAN
392 $ro = {};
393 }
394 $ro->{CPAN_VERSION} = 'undef'
395 unless defined $ro->{CPAN_VERSION};
396 $ro->{CPAN_VERSION};
397}
398
399#-> sub CPAN::Module::force ;
400sub force {
401 my($self) = @_;
402 $self->{force_update} = 1;
403}
404
405#-> sub CPAN::Module::fforce ;
406sub fforce {
407 my($self) = @_;
408 $self->{force_update} = 2;
409}
410
411#-> sub CPAN::Module::notest ;
412sub notest {
413 my($self) = @_;
414 # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
415 $self->{notest}++;
416}
417
418#-> sub CPAN::Module::rematein ;
419sub rematein {
420 my($self,$meth) = @_;
421 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
422 $meth,
423 $self->id));
424 my $cpan_file = $self->cpan_file;
425 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
426 $CPAN::Frontend->mywarn(sprintf qq{
427 The module %s isn\'t available on CPAN.
428
429 Either the module has not yet been uploaded to CPAN, or it is
430 temporary unavailable. Please contact the author to find out
431 more about the status. Try 'i %s'.
432},
433 $self->id,
434 $self->id,
435 );
436 return;
437 }
438 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
439 $pack->called_for($self->id);
440 if (exists $self->{force_update}) {
441 if ($self->{force_update} == 2) {
442 $pack->fforce($meth);
443 } else {
444 $pack->force($meth);
445 }
446 }
447 $pack->notest($meth) if exists $self->{notest} && $self->{notest};
448
449 $pack->{reqtype} ||= "";
450 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
451 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
452 if ($pack->{reqtype}) {
453 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
454 $pack->{reqtype} = $self->{reqtype};
455 if (
456 exists $pack->{install}
457 &&
458 (
459 UNIVERSAL::can($pack->{install},"failed") ?
460 $pack->{install}->failed :
461 $pack->{install} =~ /^NO/
462 )
463 ) {
464 delete $pack->{install};
465 $CPAN::Frontend->mywarn
466 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
467 }
468 }
469 } else {
470 $pack->{reqtype} = $self->{reqtype};
471 }
472
473 my $success = eval {
474 $pack->$meth();
475 };
476 my $err = $@;
477 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
478 $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
479 delete $self->{force_update};
480 delete $self->{notest};
481 if ($err) {
482 die $err;
483 }
484 return $success;
485}
486
487#-> sub CPAN::Module::perldoc ;
488sub perldoc { shift->rematein('perldoc') }
489#-> sub CPAN::Module::readme ;
490sub readme { shift->rematein('readme') }
491#-> sub CPAN::Module::look ;
492sub look { shift->rematein('look') }
493#-> sub CPAN::Module::cvs_import ;
494sub cvs_import { shift->rematein('cvs_import') }
495#-> sub CPAN::Module::get ;
496sub get { shift->rematein('get',@_) }
497#-> sub CPAN::Module::make ;
498sub make { shift->rematein('make') }
499#-> sub CPAN::Module::test ;
500sub test {
501 my $self = shift;
502 # $self->{badtestcnt} ||= 0;
503 $self->rematein('test',@_);
504}
505
506#-> sub CPAN::Module::uptodate ;
507sub uptodate {
508 my ($self) = @_;
509 local ($_);
510 my $inst = $self->inst_version or return undef;
511 my $cpan = $self->cpan_version;
512 local ($^W) = 0;
513 CPAN::Version->vgt($cpan,$inst) and return 0;
2f2071b1
AK
514 my $inst_file = $self->inst_file;
515 # trying to support deprecated.pm by Nicholas 2009-02
516 my $in_priv_or_arch = "";
517 my $isa_perl = "";
518 if ($] >= 5.011) { # probably harmful when distros say INSTALLDIRS=perl?
519 if (0 == CPAN::Version->vcmp($cpan,$inst)) {
520 if ($in_priv_or_arch = $self->_in_priv_or_arch($inst_file)) {
521 if (my $distribution = $self->distribution) {
522 unless ($isa_perl = $distribution->isa_perl) {
523 return 0;
524 }
525 }
526 }
527 }
528 }
529 CPAN->debug
530 (join
531 ("",
532 "returning uptodate. ",
533 "inst_file[$inst_file]",
534 "cpan[$cpan]inst[$inst]",
535 "in_priv_or_arch[$in_priv_or_arch]",
536 "isa_perl[$isa_perl]",
537 )) if $CPAN::DEBUG;
f9916dde
AK
538 return 1;
539}
540
2f2071b1
AK
541# returns true if installed in privlib or archlib
542sub _in_priv_or_arch {
543 my($self,$inst_file) = @_;
544 for my $confdirname (qw(archlibexp privlibexp)) {
545 my $confdir = $Config::Config{$confdirname};
546 if ($confdir eq substr($inst_file,0,length($confdir))) {
547 return 1;
548 }
549 }
550 return 0;
551}
552
f9916dde
AK
553#-> sub CPAN::Module::install ;
554sub install {
555 my($self) = @_;
556 my($doit) = 0;
557 if ($self->uptodate
558 &&
559 not exists $self->{force_update}
560 ) {
561 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
562 $self->id,
563 $self->inst_version,
564 ));
565 } else {
566 $doit = 1;
567 }
568 my $ro = $self->ro;
569 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
570 $CPAN::Frontend->mywarn(qq{
571\n\n\n ***WARNING***
572 The module $self->{ID} has no active maintainer.\n\n\n
573});
574 $CPAN::Frontend->mysleep(5);
575 }
576 return $doit ? $self->rematein('install') : 1;
577}
578#-> sub CPAN::Module::clean ;
579sub clean { shift->rematein('clean') }
580
581#-> sub CPAN::Module::inst_file ;
582sub inst_file {
583 my($self) = @_;
584 $self->_file_in_path([@INC]);
585}
586
587#-> sub CPAN::Module::available_file ;
588sub available_file {
589 my($self) = @_;
590 my $sep = $Config::Config{path_sep};
591 my $perllib = $ENV{PERL5LIB};
592 $perllib = $ENV{PERLLIB} unless defined $perllib;
593 my @perllib = split(/$sep/,$perllib) if defined $perllib;
594 my @cpan_perl5inc;
595 if ($CPAN::Perl5lib_tempfile) {
596 my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
597 @cpan_perl5inc = @{$yaml->[0]{inc} || []};
598 }
599 $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
600}
601
602#-> sub CPAN::Module::file_in_path ;
603sub _file_in_path {
604 my($self,$path) = @_;
605 my($dir,@packpath);
606 @packpath = split /::/, $self->{ID};
607 $packpath[-1] .= ".pm";
608 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
609 unshift @packpath, "Term", "ReadLine"; # historical reasons
610 }
611 foreach $dir (@$path) {
612 my $pmfile = File::Spec->catfile($dir,@packpath);
613 if (-f $pmfile) {
614 return $pmfile;
615 }
616 }
617 return;
618}
619
620#-> sub CPAN::Module::xs_file ;
621sub xs_file {
622 my($self) = @_;
623 my($dir,@packpath);
624 @packpath = split /::/, $self->{ID};
625 push @packpath, $packpath[-1];
626 $packpath[-1] .= "." . $Config::Config{'dlext'};
627 foreach $dir (@INC) {
628 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
629 if (-f $xsfile) {
630 return $xsfile;
631 }
632 }
633 return;
634}
635
636#-> sub CPAN::Module::inst_version ;
637sub inst_version {
638 my($self) = @_;
639 my $parsefile = $self->inst_file or return;
640 my $have = $self->parse_version($parsefile);
641 $have;
642}
643
644#-> sub CPAN::Module::inst_version ;
645sub available_version {
646 my($self) = @_;
647 my $parsefile = $self->available_file or return;
648 my $have = $self->parse_version($parsefile);
649 $have;
650}
651
652#-> sub CPAN::Module::parse_version ;
653sub parse_version {
654 my($self,$parsefile) = @_;
94fe740e
AK
655 alarm(10);
656 my $have = eval {
657 local $SIG{ALRM} = sub { die "alarm\n" };
658 MM->parse_version($parsefile);
659 };
f9916dde
AK
660 if ($@) {
661 $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
662 }
94fe740e 663 alarm(0);
f9916dde
AK
664 my $leastsanity = eval { defined $have && length $have; };
665 $have = "undef" unless $leastsanity;
666 $have =~ s/^ //; # since the %vd hack these two lines here are needed
667 $have =~ s/ $//; # trailing whitespace happens all the time
668
669 $have = CPAN::Version->readable($have);
670
671 $have =~ s/\s*//g; # stringify to float around floating point issues
672 $have; # no stringify needed, \s* above matches always
673}
674
675#-> sub CPAN::Module::reports
676sub reports {
677 my($self) = @_;
678 $self->distribution->reports;
679}
680
6811;