Commit | Line | Data |
f9916dde |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
2 | # vim: ts=4 sts=4 sw=4: |
3 | package CPAN::Module; |
4 | use strict; |
5 | @CPAN::Module::ISA = qw(CPAN::InfoObj); |
6 | |
7 | use vars qw( |
8 | $VERSION |
9 | ); |
10 | $VERSION = "5.5"; |
11 | |
12 | # Accessors |
13 | #-> sub CPAN::Module::userid |
14 | sub 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 |
21 | sub description { |
22 | my $self = shift; |
23 | my $ro = $self->ro or return ""; |
24 | $ro->{description} |
25 | } |
26 | |
27 | #-> sub CPAN::Module::distribution |
28 | sub distribution { |
29 | my($self) = @_; |
30 | CPAN::Shell->expand("Distribution",$self->cpan_file); |
31 | } |
32 | |
33 | #-> sub CPAN::Module::_is_representative_module |
34 | sub _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 |
49 | sub 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 ; |
59 | sub 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 ; |
117 | sub 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 |
155 | sub 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 ; |
202 | sub 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 |
320 | sub 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 |
353 | sub 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 ; |
386 | sub 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 ; |
400 | sub force { |
401 | my($self) = @_; |
402 | $self->{force_update} = 1; |
403 | } |
404 | |
405 | #-> sub CPAN::Module::fforce ; |
406 | sub fforce { |
407 | my($self) = @_; |
408 | $self->{force_update} = 2; |
409 | } |
410 | |
411 | #-> sub CPAN::Module::notest ; |
412 | sub notest { |
413 | my($self) = @_; |
414 | # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module"); |
415 | $self->{notest}++; |
416 | } |
417 | |
418 | #-> sub CPAN::Module::rematein ; |
419 | sub 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 ; |
488 | sub perldoc { shift->rematein('perldoc') } |
489 | #-> sub CPAN::Module::readme ; |
490 | sub readme { shift->rematein('readme') } |
491 | #-> sub CPAN::Module::look ; |
492 | sub look { shift->rematein('look') } |
493 | #-> sub CPAN::Module::cvs_import ; |
494 | sub cvs_import { shift->rematein('cvs_import') } |
495 | #-> sub CPAN::Module::get ; |
496 | sub get { shift->rematein('get',@_) } |
497 | #-> sub CPAN::Module::make ; |
498 | sub make { shift->rematein('make') } |
499 | #-> sub CPAN::Module::test ; |
500 | sub test { |
501 | my $self = shift; |
502 | # $self->{badtestcnt} ||= 0; |
503 | $self->rematein('test',@_); |
504 | } |
505 | |
506 | #-> sub CPAN::Module::uptodate ; |
507 | sub 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; |
514 | CPAN->debug(join("", |
515 | "returning uptodate. inst_file[", |
516 | $self->inst_file, |
517 | "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG; |
518 | return 1; |
519 | } |
520 | |
521 | #-> sub CPAN::Module::install ; |
522 | sub install { |
523 | my($self) = @_; |
524 | my($doit) = 0; |
525 | if ($self->uptodate |
526 | && |
527 | not exists $self->{force_update} |
528 | ) { |
529 | $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n", |
530 | $self->id, |
531 | $self->inst_version, |
532 | )); |
533 | } else { |
534 | $doit = 1; |
535 | } |
536 | my $ro = $self->ro; |
537 | if ($ro && $ro->{stats} && $ro->{stats} eq "a") { |
538 | $CPAN::Frontend->mywarn(qq{ |
539 | \n\n\n ***WARNING*** |
540 | The module $self->{ID} has no active maintainer.\n\n\n |
541 | }); |
542 | $CPAN::Frontend->mysleep(5); |
543 | } |
544 | return $doit ? $self->rematein('install') : 1; |
545 | } |
546 | #-> sub CPAN::Module::clean ; |
547 | sub clean { shift->rematein('clean') } |
548 | |
549 | #-> sub CPAN::Module::inst_file ; |
550 | sub inst_file { |
551 | my($self) = @_; |
552 | $self->_file_in_path([@INC]); |
553 | } |
554 | |
555 | #-> sub CPAN::Module::available_file ; |
556 | sub available_file { |
557 | my($self) = @_; |
558 | my $sep = $Config::Config{path_sep}; |
559 | my $perllib = $ENV{PERL5LIB}; |
560 | $perllib = $ENV{PERLLIB} unless defined $perllib; |
561 | my @perllib = split(/$sep/,$perllib) if defined $perllib; |
562 | my @cpan_perl5inc; |
563 | if ($CPAN::Perl5lib_tempfile) { |
564 | my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile); |
565 | @cpan_perl5inc = @{$yaml->[0]{inc} || []}; |
566 | } |
567 | $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]); |
568 | } |
569 | |
570 | #-> sub CPAN::Module::file_in_path ; |
571 | sub _file_in_path { |
572 | my($self,$path) = @_; |
573 | my($dir,@packpath); |
574 | @packpath = split /::/, $self->{ID}; |
575 | $packpath[-1] .= ".pm"; |
576 | if (@packpath == 1 && $packpath[0] eq "readline.pm") { |
577 | unshift @packpath, "Term", "ReadLine"; # historical reasons |
578 | } |
579 | foreach $dir (@$path) { |
580 | my $pmfile = File::Spec->catfile($dir,@packpath); |
581 | if (-f $pmfile) { |
582 | return $pmfile; |
583 | } |
584 | } |
585 | return; |
586 | } |
587 | |
588 | #-> sub CPAN::Module::xs_file ; |
589 | sub xs_file { |
590 | my($self) = @_; |
591 | my($dir,@packpath); |
592 | @packpath = split /::/, $self->{ID}; |
593 | push @packpath, $packpath[-1]; |
594 | $packpath[-1] .= "." . $Config::Config{'dlext'}; |
595 | foreach $dir (@INC) { |
596 | my $xsfile = File::Spec->catfile($dir,'auto',@packpath); |
597 | if (-f $xsfile) { |
598 | return $xsfile; |
599 | } |
600 | } |
601 | return; |
602 | } |
603 | |
604 | #-> sub CPAN::Module::inst_version ; |
605 | sub inst_version { |
606 | my($self) = @_; |
607 | my $parsefile = $self->inst_file or return; |
608 | my $have = $self->parse_version($parsefile); |
609 | $have; |
610 | } |
611 | |
612 | #-> sub CPAN::Module::inst_version ; |
613 | sub available_version { |
614 | my($self) = @_; |
615 | my $parsefile = $self->available_file or return; |
616 | my $have = $self->parse_version($parsefile); |
617 | $have; |
618 | } |
619 | |
620 | #-> sub CPAN::Module::parse_version ; |
621 | sub parse_version { |
622 | my($self,$parsefile) = @_; |
623 | my $have = eval { MM->parse_version($parsefile); }; |
624 | if ($@) { |
625 | $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n"); |
626 | } |
627 | my $leastsanity = eval { defined $have && length $have; }; |
628 | $have = "undef" unless $leastsanity; |
629 | $have =~ s/^ //; # since the %vd hack these two lines here are needed |
630 | $have =~ s/ $//; # trailing whitespace happens all the time |
631 | |
632 | $have = CPAN::Version->readable($have); |
633 | |
634 | $have =~ s/\s*//g; # stringify to float around floating point issues |
635 | $have; # no stringify needed, \s* above matches always |
636 | } |
637 | |
638 | #-> sub CPAN::Module::reports |
639 | sub reports { |
640 | my($self) = @_; |
641 | $self->distribution->reports; |
642 | } |
643 | |
644 | 1; |