File Coverage

blib/lib/Module/Metadata.pm
Criterion Covered Total %
statement 341 345 98.8
branch 145 188 77.1
condition 76 108 70.3
subroutine 52 52 100.0
pod 15 15 100.0
total 629 708 88.8


line stmt bran cond sub pod time code
1             # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2             # vim:ts=8:sw=2:et:sta:sts=2:tw=78
3             package Module::Metadata; # git description: v1.000036-4-g435a294
4             # ABSTRACT: Gather package and POD information from perl module files
5              
6             # Adapted from Perl-licensed code originally distributed with
7             # Module-Build by Ken Williams
8              
9             # This module provides routines to gather information about
10             # perl modules (assuming this may be expanded in the distant
11             # parrot future to look at other types of modules).
12              
13 113     113   10776 sub __clean_eval { eval $_[0] }
  6     7   49  
  6     5   13  
  6     5   45  
  4     5   30  
  4     5   9  
  4     4   22  
  4     4   28  
  4     4   10  
  4     4   21  
  4     1   29  
  4     1   8  
  4     1   21  
  4     1   28  
  4         11  
  4         18  
  3         26  
  3         6  
  3         15  
  3         21  
  3         7  
  3         17  
  3         23  
  3         16  
  3         14  
  3         22  
  3         10  
  3         15  
14 10     10   475600 use strict;
  10         78  
  10         286  
15 10     10   59 use warnings;
  10         18  
  10         368  
16              
17             our $VERSION = '1.000037';
18              
19 10     10   58 use Carp qw/croak/;
  10         32  
  10         402  
20 10     10   65 use File::Spec;
  10         33  
  10         683  
21             BEGIN {
22             # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
23             eval {
24 10         85 require Fcntl; Fcntl->import('SEEK_SET'); 1;
  10         245  
  10         311  
25 2         6 } or *SEEK_SET = sub { 0 }
26 10 50   10   41 }
27 10     10   3637 use version 0.87;
  10         15547  
  10         61  
28             BEGIN {
29 10 50   10   1172 if ($INC{'Log/Contextual.pm'}) {
30 2         15 require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
31 2         6 Log::Contextual->import('log_info',
32             '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
33             );
34             }
35             else {
36 10     2   209 *log_info = sub (&) { warn $_[0]->() };
  2         14  
37             }
38             }
39 10     10   78 use File::Find qw(find);
  10         27  
  10         37491  
40              
41             my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
42              
43             my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
44             [a-zA-Z_] # the first word CANNOT start with a digit
45             (?:
46             [\w']? # can contain letters, digits, _, or ticks
47             \w # But, NO multi-ticks or trailing ticks
48             )*
49             }x;
50              
51             my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
52             \w # the 2nd+ word CAN start with digits
53             (?:
54             [\w']? # and can contain letters or ticks
55             \w # But, NO multi-ticks or trailing ticks
56             )*
57             }x;
58              
59             my $PKG_NAME_REGEXP = qr{ # match a package name
60             (?: :: )? # a pkg name can start with arisdottle
61             $PKG_FIRST_WORD_REGEXP # a package word
62             (?:
63             (?: :: )+ ### arisdottle (allow one or many times)
64             $PKG_ADDL_WORD_REGEXP ### a package word
65             )* # ^ zero, one or many times
66             (?:
67             :: # allow trailing arisdottle
68             )?
69             }x;
70              
71             my $PKG_REGEXP = qr{ # match a package declaration
72             ^[\s\{;]* # intro chars on a line
73             package # the word 'package'
74             \s+ # whitespace
75             ($PKG_NAME_REGEXP) # a package name
76             \s* # optional whitespace
77             ($V_NUM_REGEXP)? # optional version number
78             \s* # optional whitesapce
79             [;\{] # semicolon line terminator or block start (since 5.16)
80             }x;
81              
82             my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
83             ([\$*]) # sigil - $ or *
84             (
85             ( # optional leading package name
86             (?:::|\')? # possibly starting like just :: (a la $::VERSION)
87             (?:\w+(?:::|\'))* # Foo::Bar:: ...
88             )?
89             VERSION
90             )\b
91             }x;
92              
93             my $VERS_REGEXP = qr{ # match a VERSION definition
94             (?:
95             \(\s*$VARNAME_REGEXP\s*\) # with parens
96             |
97             $VARNAME_REGEXP # without parens
98             )
99             \s*
100             =[^=~>] # = but not ==, nor =~, nor =>
101             }x;
102              
103             sub new_from_file {
104 103     103 1 260272 my $class = shift;
105 103         1676 my $filename = File::Spec->rel2abs( shift );
106              
107 103 100 66     2012 return undef unless defined( $filename ) && -f $filename;
108 102         476 return $class->_init(undef, $filename, @_);
109             }
110              
111             sub new_from_handle {
112 7     7 1 2526 my $class = shift;
113 7         14 my $handle = shift;
114 7         16 my $filename = shift;
115 7 100 66     47 return undef unless defined($handle) && defined($filename);
116 6         124 $filename = File::Spec->rel2abs( $filename );
117              
118 6         31 return $class->_init(undef, $filename, @_, handle => $handle);
119              
120             }
121              
122              
123             sub new_from_module {
124 9     9 1 4791 my $class = shift;
125 9         21 my $module = shift;
126 9         35 my %props = @_;
127              
128 9   100     43 $props{inc} ||= \@INC;
129 9         27 my $filename = $class->find_module_by_name( $module, $props{inc} );
130 9 100 66     124 return undef unless defined( $filename ) && -f $filename;
131 8         53 return $class->_init($module, $filename, %props);
132             }
133              
134             {
135              
136             my $compare_versions = sub {
137             my ($v1, $op, $v2) = @_;
138             $v1 = version->new($v1)
139             unless UNIVERSAL::isa($v1,'version');
140              
141             my $eval_str = "\$v1 $op \$v2";
142             my $result = eval $eval_str;
143             log_info { "error comparing versions: '$eval_str' $@" } if $@;
144              
145             return $result;
146             };
147              
148             my $normalize_version = sub {
149             my ($version) = @_;
150             if ( $version =~ /[=<>!,]/ ) { # logic, not just version
151             # take as is without modification
152             }
153             elsif ( ref $version eq 'version' ) { # version objects
154             $version = $version->is_qv ? $version->normal : $version->stringify;
155             }
156             elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
157             # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
158             $version = "v$version";
159             }
160             else {
161             # leave alone
162             }
163             return $version;
164             };
165              
166             # separate out some of the conflict resolution logic
167              
168             my $resolve_module_versions = sub {
169             my $packages = shift;
170              
171             my( $file, $version );
172             my $err = '';
173             foreach my $p ( @$packages ) {
174             if ( defined( $p->{version} ) ) {
175             if ( defined( $version ) ) {
176             if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
177             $err .= " $p->{file} ($p->{version})\n";
178             }
179             else {
180             # same version declared multiple times, ignore
181             }
182             }
183             else {
184             $file = $p->{file};
185             $version = $p->{version};
186             }
187             }
188             $file ||= $p->{file} if defined( $p->{file} );
189             }
190              
191             if ( $err ) {
192             $err = " $file ($version)\n" . $err;
193             }
194              
195             my %result = (
196             file => $file,
197             version => $version,
198             err => $err
199             );
200              
201             return \%result;
202             };
203              
204             sub provides {
205 4     4 1 1862 my $class = shift;
206              
207 4 50       21 croak "provides() requires key/value pairs \n" if @_ % 2;
208 4         23 my %args = @_;
209              
210             croak "provides() takes only one of 'dir' or 'files'\n"
211 4 50 33     17 if $args{dir} && $args{files};
212              
213             croak "provides() requires a 'version' argument"
214 4 50       15 unless defined $args{version};
215              
216             croak "provides() does not support version '$args{version}' metadata"
217 4 50       35 unless grep $args{version} eq $_, qw/1.4 2/;
218              
219 4 100       11 $args{prefix} = 'lib' unless defined $args{prefix};
220              
221 4         15 my $p;
222 4 50       157 if ( $args{dir} ) {
223 4         10 $p = $class->package_versions_from_directory($args{dir});
224             }
225             else {
226             croak "provides() requires 'files' to be an array reference\n"
227 2 0       27 unless ref $args{files} eq 'ARRAY';
228 2         14 $p = $class->package_versions_from_directory($args{files});
229             }
230              
231             # Now, fix up files with prefix
232 4 50       12 if ( length $args{prefix} ) { # check in case disabled with q{}
233 4         14 $args{prefix} =~ s{/$}{};
234 4         120 for my $v ( values %$p ) {
235 6         17 $v->{file} = "$args{prefix}/$v->{file}";
236             }
237             }
238              
239 4         14 return $p
240             }
241              
242             sub package_versions_from_directory {
243 6     6 1 1266 my ( $class, $dir, $files ) = @_;
244              
245 6         12 my @files;
246              
247 6 100       21 if ( $files ) {
248 3         16 @files = @$files;
249             }
250             else {
251             find( {
252             wanted => sub {
253 8 100 66 8   442 push @files, $_ if -f $_ && /\.pm$/;
254             },
255 5         330 no_chdir => 1,
256             }, $dir );
257             }
258              
259             # First, we enumerate all packages & versions,
260             # separating into primary & alternative candidates
261 6         43 my( %prime, %alt );
262 6         12 foreach my $file (@files) {
263 6         293 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
264 6         35 my @path = File::Spec->splitdir( $mapped_filename );
265 6         25 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
266              
267 6         32 my $pm_info = $class->new_from_file( $file );
268              
269 6         30 foreach my $package ( $pm_info->packages_inside ) {
270 22 100       44 next if $package eq 'main'; # main can appear numerous times, ignore
271 18 100       41 next if $package eq 'DB'; # special debugging package, ignore
272 14 100       82 next if grep /^_/, split( /::/, $package ); # private package, ignore
273              
274 10         34 my $version = $pm_info->version( $package );
275              
276 10 100       30 $prime_package = $package if lc($prime_package) eq lc($package);
277 10 100       32 if ( $package eq $prime_package ) {
278 6 50       13 if ( exists( $prime{$package} ) ) {
279 2         11 croak "Unexpected conflict in '$package'; multiple versions found.\n";
280             }
281             else {
282 6 50       36 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
283 6         26 $prime{$package}{file} = $mapped_filename;
284 6 50       27 $prime{$package}{version} = $version if defined( $version );
285             }
286             }
287             else {
288 5         26 push( @{$alt{$package}}, {
  5         28  
289             file => $mapped_filename,
290             version => $version,
291             } );
292             }
293             }
294             }
295              
296             # Then we iterate over all the packages found above, identifying conflicts
297             # and selecting the "best" candidate for recording the file & version
298             # for each package.
299 5         28 foreach my $package ( keys( %alt ) ) {
300 5         23 my $result = $resolve_module_versions->( $alt{$package} );
301              
302 5 50       14 if ( exists( $prime{$package} ) ) { # primary package selected
303              
304 1 0       6 if ( $result->{err} ) {
    0          
305             # Use the selected primary package, but there are conflicting
306             # errors among multiple alternative packages that need to be
307             # reported
308             log_info {
309             "Found conflicting versions for package '$package'\n" .
310             " $prime{$package}{file} ($prime{$package}{version})\n" .
311             $result->{err}
312 1     2   7 };
  1         4  
313              
314             }
315             elsif ( defined( $result->{version} ) ) {
316             # There is a primary package selected, and exactly one
317             # alternative package
318              
319 1 0 0     5 if ( exists( $prime{$package}{version} ) &&
320             defined( $prime{$package}{version} ) ) {
321             # Unless the version of the primary package agrees with the
322             # version of the alternative package, report a conflict
323 1 0       8 if ( $compare_versions->(
324             $prime{$package}{version}, '!=', $result->{version}
325             )
326             ) {
327              
328             log_info {
329 1     2   7 "Found conflicting versions for package '$package'\n" .
330             " $prime{$package}{file} ($prime{$package}{version})\n" .
331             " $result->{file} ($result->{version})\n"
332 1         2 };
333             }
334              
335             }
336             else {
337             # The prime package selected has no version so, we choose to
338             # use any alternative package that does have a version
339 1         7 $prime{$package}{file} = $result->{file};
340 1         3 $prime{$package}{version} = $result->{version};
341             }
342              
343             }
344             else {
345             # no alt package found with a version, but we have a prime
346             # package so we use it whether it has a version or not
347             }
348              
349             }
350             else { # No primary package was selected, use the best alternative
351              
352 5 50       16 if ( $result->{err} ) {
353             log_info {
354             "Found conflicting versions for package '$package'\n" .
355             $result->{err}
356 1     2   8 };
  1         2  
357             }
358              
359             # Despite possible conflicting versions, we choose to record
360             # something rather than nothing
361 5         15 $prime{$package}{file} = $result->{file};
362             $prime{$package}{version} = $result->{version}
363 5 50       21 if defined( $result->{version} );
364             }
365             }
366              
367             # Normalize versions. Can't use exists() here because of bug in YAML::Node.
368             # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
369 5         19 for (grep defined $_->{version}, values %prime) {
370 9         32 $_->{version} = $normalize_version->( $_->{version} );
371             }
372              
373 5         32 return \%prime;
374             }
375             }
376              
377              
378             sub _init {
379 111     112   212 my $class = shift;
380 111         178 my $module = shift;
381 111         180 my $filename = shift;
382 111         227 my %props = @_;
383              
384 111         222 my $handle = delete $props{handle};
385 111         208 my( %valid_props, @valid_props );
386 111         308 @valid_props = qw( collect_pod inc decode_pod );
387 111         422 @valid_props{@valid_props} = delete( @props{@valid_props} );
388 111 50       265 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
  1         3  
389              
390 111         1322 my %data = (
391             module => $module,
392             filename => $filename,
393             version => undef,
394             packages => [],
395             versions => {},
396             pod => {},
397             pod_headings => [],
398             collect_pod => 0,
399              
400             %valid_props,
401             );
402              
403 111         316 my $self = bless(\%data, $class);
404              
405 111 100       255 if ( not $handle ) {
406 107         238 my $filename = $self->{filename};
407 107 50       3552 open $handle, '<', $filename
408             or croak( "Can't open '$filename': $!" );
409              
410 107         440 $self->_handle_bom($handle, $filename);
411             }
412 111         363 $self->_parse_fh($handle);
413              
414 111         324 @{$self->{packages}} = __uniq(@{$self->{packages}});
  111         289  
  111         327  
415              
416 111 100 66     353 unless($self->{module} and length($self->{module})) {
417             # CAVEAT (possible TODO): .pmc files not treated the same as .pm
418 105 100       683 if ($self->{filename} =~ /\.pm$/) {
419 96         1403 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
420 96         446 $f =~ s/\..+$//;
421 96         166 my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
  96         780  
422 96         281 $self->{module} = shift(@candidates); # this may be undef
423             }
424             else {
425             # this seems like an atrocious heuristic, albeit marginally better than
426             # what was here before. It should be rewritten entirely to be more like
427             # "if it's not a .pm file, it's not require()able as a name, therefore
428             # name() should be undef."
429 10 100 100     18 if ((grep /main/, @{$self->{packages}})
  10         52  
430 4         20 or (grep /main/, keys %{$self->{versions}})) {
431 9         22 $self->{module} = 'main';
432             }
433             else {
434             # TODO: this should maybe default to undef instead
435 2   50     15 $self->{module} = $self->{packages}[0] || '';
436             }
437             }
438             }
439              
440             $self->{version} = $self->{versions}{$self->{module}}
441 111 100       364 if defined( $self->{module} );
442              
443 111         1857 return $self;
444             }
445              
446             # class method
447             sub _do_find_module {
448 9     10   23 my $class = shift;
449 9   33     25 my $module = shift || croak 'find_module_by_name() requires a package name';
450 9   100     29 my $dirs = shift || \@INC;
451              
452 9         102 my $file = File::Spec->catfile(split( /::/, $module));
453 9         30 foreach my $dir ( @$dirs ) {
454 11         77 my $testfile = File::Spec->catfile($dir, $file);
455 10 50 33     172 return [ File::Spec->rel2abs( $testfile ), $dir ]
456             if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
457             # CAVEAT (possible TODO): .pmc files are not discoverable here
458 10         27 $testfile .= '.pm';
459 10 100       309 return [ File::Spec->rel2abs( $testfile ), $dir ]
460             if -e $testfile;
461             }
462 1         4 return;
463             }
464              
465             # class method
466             sub find_module_by_name {
467 8 100   10 1 447 my $found = shift()->_do_find_module(@_) or return;
468 7         28 return $found->[0];
469             }
470              
471             # class method
472             sub find_module_dir_by_name {
473 0 0   2 1 0 my $found = shift()->_do_find_module(@_) or return;
474 0         0 return $found->[1];
475             }
476              
477              
478             # given a line of perl code, attempt to parse it if it looks like a
479             # $VERSION assignment, returning sigil, full name, & package name
480             sub _parse_version_expression {
481 135     137   225 my $self = shift;
482 135         267 my $line = shift;
483              
484 135         229 my( $sigil, $variable_name, $package);
485 135 100       1004 if ( $line =~ /$VERS_REGEXP/o ) {
486 116 100       545 ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
487 116 100       273 if ( $package ) {
488 20 100       74 $package = ($package eq '::') ? 'main' : $package;
489 20         89 $package =~ s/::$//;
490             }
491             }
492              
493 135         459 return ( $sigil, $variable_name, $package );
494             }
495              
496             # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
497             # If there's one, then skip it and set the :encoding layer appropriately.
498             sub _handle_bom {
499 106     108   252 my ($self, $fh, $filename) = @_;
500              
501 106         264 my $pos = tell $fh;
502 106 50       234 return unless defined $pos;
503              
504 106         175 my $buf = ' ' x 2;
505 106         1258 my $count = read $fh, $buf, length $buf;
506 106 50 33     546 return unless defined $count and $count >= 2;
507              
508 106         154 my $encoding;
509 106 100       398 if ( $buf eq "\x{FE}\x{FF}" ) {
    100          
    100          
510 1         3 $encoding = 'UTF-16BE';
511             }
512             elsif ( $buf eq "\x{FF}\x{FE}" ) {
513 1         2 $encoding = 'UTF-16LE';
514             }
515             elsif ( $buf eq "\x{EF}\x{BB}" ) {
516 1         3 $buf = ' ';
517 1         3 $count = read $fh, $buf, length $buf;
518 1 50 33     8 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
      33        
519 1         2 $encoding = 'UTF-8';
520             }
521             }
522              
523 106 100       209 if ( defined $encoding ) {
524 3 50       14 if ( "$]" >= 5.008 ) {
525 3     2   53 binmode( $fh, ":encoding($encoding)" );
  1         6  
  1         2  
  1         6  
526             }
527             }
528             else {
529 103 50       1243 seek $fh, $pos, SEEK_SET
530             or croak( sprintf "Can't reset position to the top of '$filename'" );
531             }
532              
533 106         15618 return $encoding;
534             }
535              
536             sub _parse_fh {
537 110     112   229 my ($self, $fh) = @_;
538              
539 110         264 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
540 110         228 my( @packages, %vers, %pod, @pod );
541 110         180 my $package = 'main';
542 110         166 my $pod_sect = '';
543 110         150 my $pod_data = '';
544 110         151 my $in_end = 0;
545 110         157 my $encoding = '';
546              
547 110         1013 while (defined( my $line = <$fh> )) {
548 1690         3243 my $line_num = $.;
549              
550 1690         2685 chomp( $line );
551              
552             # From toke.c : any line that begins by "=X", where X is an alphabetic
553             # character, introduces a POD segment.
554 1690         2588 my $is_cut;
555 1690 100       3368 if ( $line =~ /^=([a-zA-Z].*)/ ) {
556 96         210 my $cmd = $1;
557             # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
558             # character (which includes the newline, but here we chomped it away).
559 96         166 $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
560 96         138 $in_pod = !$is_cut;
561             }
562              
563 1690 100       3131 if ( $in_pod ) {
    100          
564              
565 454 100       930 if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
    100          
566 44         107 push( @pod, $1 );
567 44 100 100     110 if ( $self->{collect_pod} && length( $pod_data ) ) {
568 4         13 $pod{$pod_sect} = $pod_data;
569 4         8 $pod_data = '';
570             }
571 44         80 $pod_sect = $1;
572             }
573             elsif ( $self->{collect_pod} ) {
574 25 100 100     98 if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) {
575 1         4 $encoding = $1;
576             }
577 25         49 $pod_data .= "$line\n";
578             }
579 454         1306 next;
580             }
581             elsif ( $is_cut ) {
582 10 100 66     34 if ( $self->{collect_pod} && length( $pod_data ) ) {
583 2         5 $pod{$pod_sect} = $pod_data;
584 2         2 $pod_data = '';
585             }
586 10         16 $pod_sect = '';
587 10         106 next;
588             }
589              
590             # Skip after __END__
591 1226 100       1970 next if $in_end;
592              
593             # Skip comments in code
594 1224 100       2746 next if $line =~ /^\s*#/;
595              
596             # Would be nice if we could also check $in_string or something too
597 1126 100       2355 if ($line eq '__END__') {
598 2         5 $in_end++;
599 2         9 next;
600             }
601              
602 1124 100       2178 last if $line eq '__DATA__';
603              
604             # parse $line to see if it's a $VERSION declaration
605 1123 100       3379 my( $version_sigil, $version_fullname, $version_package ) =
606             index($line, 'VERSION') >= 1
607             ? $self->_parse_version_expression( $line )
608             : ();
609              
610 1123 100 100     9415 if ( $line =~ /$PKG_REGEXP/o ) {
    100 100        
    100 100        
    100 100        
    100 100        
      100        
611 136         392 $package = $1;
612 136         269 my $version = $2;
613 136 100       515 push( @packages, $package ) unless grep( $package eq $_, @packages );
614 136 100       327 $need_vers = defined $version ? 0 : 1;
615              
616 136 100 100     960 if ( not exists $vers{$package} and defined $version ){
617             # Upgrade to a version object.
618 6         12 my $dwim_version = eval { _dwim_version($version) };
  6         17  
619 6 50       17 croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
620             unless defined $dwim_version; # "0" is OK!
621 6         180 $vers{$package} = $dwim_version;
622             }
623             }
624              
625             # VERSION defined with full package spec, i.e. $Module::VERSION
626             elsif ( $version_fullname && $version_package ) {
627             # we do NOT save this package in found @packages
628 20 100       65 $need_vers = 0 if $version_package eq $package;
629              
630 20 100 66     151 unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
631 18         54 $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
632             }
633             }
634              
635             # first non-comment line in undeclared package main is VERSION
636             elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
637 8         17 $need_vers = 0;
638 8         23 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
639 8         23 $vers{$package} = $v;
640 8         90 push( @packages, 'main' );
641             }
642              
643             # first non-comment line in undeclared package defines package main
644             elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
645 8         17 $need_vers = 1;
646 8         24 $vers{main} = '';
647 8         71 push( @packages, 'main' );
648             }
649              
650             # only keep if this is the first $VERSION seen
651             elsif ( $version_fullname && $need_vers ) {
652 85         139 $need_vers = 0;
653 85         197 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
654              
655 85 50 66     287 unless ( defined $vers{$package} && length $vers{$package} ) {
656 85         715 $vers{$package} = $v;
657             }
658             }
659             } # end loop over each line
660              
661 110 100 100     452 if ( $self->{collect_pod} && length($pod_data) ) {
662 1         4 $pod{$pod_sect} = $pod_data;
663             }
664              
665 110 100 66     272 if ( $self->{decode_pod} && $encoding ) {
666 1         6 require Encode;
667 1         14 $_ = Encode::decode( $encoding, $_ ) for values %pod;
668             }
669              
670 110         661 $self->{versions} = \%vers;
671 110         217 $self->{packages} = \@packages;
672 110         202 $self->{pod} = \%pod;
673 110         330 $self->{pod_headings} = \@pod;
674             }
675              
676             sub __uniq (@)
677             {
678 110     112   174 my (%seen, $key);
679 110         590 grep !$seen{ $key = $_ }++, @_;
680             }
681              
682             {
683             my $pn = 0;
684             sub _evaluate_version_line {
685 111     113   174 my $self = shift;
686 111         241 my( $sigil, $variable_name, $line ) = @_;
687              
688             # We compile into a local sub because 'use version' would cause
689             # compiletime/runtime issues with local()
690 111         183 $pn++; # everybody gets their own package
691 111         518 my $eval = qq{ my \$dummy = q# Hide from _packages_inside()
692             #; package Module::Metadata::_version::p${pn};
693             use version;
694             sub {
695             local $sigil$variable_name;
696             $line;
697             return \$$variable_name if defined \$$variable_name;
698             return \$Module::Metadata::_version::p${pn}::$variable_name;
699             };
700             };
701              
702 111 50       554 $eval = $1 if $eval =~ m{^(.+)}s;
703              
704 111         375 local $^W;
705             # Try to get the $VERSION
706 111         262 my $vsub = __clean_eval($eval);
707             # some modules say $VERSION $Foo::Bar::VERSION, but Foo::Bar isn't
708             # installed, so we need to hunt in ./lib for it
709 111 50 33     436 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
710 0         0 local @INC = ('lib',@INC);
711 0         0 $vsub = __clean_eval($eval);
712             }
713 111 50       244 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
714             if $@;
715              
716 111 50       328 (ref($vsub) eq 'CODE') or
717             croak "failed to build version sub for $self->{filename}";
718              
719 111         181 my $result = eval { $vsub->() };
  111         2366  
720             # FIXME: $eval is not the right thing to print here
721 111 50       301 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
722             if $@;
723              
724             # Upgrade it into a version object
725 111         163 my $version = eval { _dwim_version($result) };
  111         261  
726              
727             # FIXME: $eval is not the right thing to print here
728 111 50       229 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
729             unless defined $version; # "0" is OK!
730              
731 111         706 return $version;
732             }
733             }
734              
735             # Try to DWIM when things fail the lax version test in obvious ways
736             {
737             my @version_prep = (
738             # Best case, it just works
739             sub { return shift },
740              
741             # If we still don't have a version, try stripping any
742             # trailing junk that is prohibited by lax rules
743             sub {
744             my $v = shift;
745             $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
746             return $v;
747             },
748              
749             # Activestate apparently creates custom versions like '1.23_45_01', which
750             # cause version.pm to think it's an invalid alpha. So check for that
751             # and strip them
752             sub {
753             my $v = shift;
754             my $num_dots = () = $v =~ m{(\.)}g;
755             my $num_unders = () = $v =~ m{(_)}g;
756             my $leading_v = substr($v,0,1) eq 'v';
757             if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
758             $v =~ s{_}{}g;
759             $num_unders = () = $v =~ m{(_)}g;
760             }
761             return $v;
762             },
763              
764             # Worst case, try numifying it like we would have before version objects
765             sub {
766             my $v = shift;
767 10     10   86 no warnings 'numeric';
  10         31  
  10         4199  
768             return 0 + $v;
769             },
770              
771             );
772              
773             sub _dwim_version {
774 117     119   228 my ($result) = shift;
775              
776 117 100       257 return $result if ref($result) eq 'version';
777              
778 112         208 my ($version, $error);
779 112         262 for my $f (@version_prep) {
780 124         256 $result = $f->($result);
781 124         185 $version = eval { version->new($result) };
  124         1004  
782 124 100 66     345 $error ||= $@ if $@; # capture first failure
783 124 100       295 last if defined $version;
784             }
785              
786 112 50       219 croak $error unless defined $version;
787              
788 112         235 return $version;
789             }
790             }
791              
792             ############################################################
793              
794             # accessors
795 21     22 1 211 sub name { $_[0]->{module} }
796              
797 1     2 1 4 sub filename { $_[0]->{filename} }
798 31     32 1 453 sub packages_inside { @{$_[0]->{packages}} }
  31         122  
799 2     3 1 5 sub pod_inside { @{$_[0]->{pod_headings}} }
  2         9  
800 4     5 1 1082 sub contains_pod { 0+@{$_[0]->{pod_headings}} }
  4         20  
801              
802             sub version {
803 100     101 1 1082 my $self = shift;
804 100   100     408 my $mod = shift || $self->{module};
805 100         147 my $vers;
806 100 100 66     552 if ( defined( $mod ) && length( $mod ) &&
      100        
807             exists( $self->{versions}{$mod} ) ) {
808 85         361 return $self->{versions}{$mod};
809             }
810             else {
811 15         60 return undef;
812             }
813             }
814              
815             sub pod {
816 5     6 1 670 my $self = shift;
817 5         12 my $sect = shift;
818 5 100 33     35 if ( defined( $sect ) && length( $sect ) &&
      66        
819             exists( $self->{pod}{$sect} ) ) {
820 3         10 return $self->{pod}{$sect};
821             }
822             else {
823 2         9 return undef;
824             }
825             }
826              
827             sub is_indexable {
828 8     9 1 23 my ($self, $package) = @_;
829              
830 8         19 my @indexable_packages = grep $_ ne 'main', $self->packages_inside;
831              
832             # check for specific package, if provided
833 8 100       51 return !! grep $_ eq $package, @indexable_packages if $package;
834              
835             # otherwise, check for any indexable packages at all
836 2         10 return !! @indexable_packages;
837             }
838              
839             1;
840              
841             __END__