X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FModule%2FMetadata.pm;h=0afa14e11fbbd85817ea852bcf0e0c66c431946d;hb=141ef4bd703e52632c28b3fea6f2c30b19dde2f2;hp=0b48828826aea5f25aaba4378109e498a572d90f;hpb=c4c5b1f0322a07e5cd539a571686560b643de360;p=p5sagit%2FModule-Metadata.git diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm index 0b48828..0afa14e 100644 --- a/lib/Module/Metadata.pm +++ b/lib/Module/Metadata.pm @@ -10,8 +10,9 @@ package Module::Metadata; # parrot future to look at other types of modules). use strict; -use vars qw($VERSION); -$VERSION = '1.000013'; +use warnings; + +our $VERSION = '1.000019'; $VERSION = eval $VERSION; use Carp qw/croak/; @@ -86,7 +87,7 @@ my $VERS_REGEXP = qr{ # match a VERSION definition $VARNAME_REGEXP # without parens ) \s* - =[^=~] # = but not ==, nor =~ + =[^=~>] # = but not ==, nor =~, nor => }x; sub new_from_file { @@ -161,19 +162,19 @@ sub new_from_module { my $err = ''; foreach my $p ( @$packages ) { if ( defined( $p->{version} ) ) { - if ( defined( $version ) ) { - if ( $compare_versions->( $version, '!=', $p->{version} ) ) { - $err .= " $p->{file} ($p->{version})\n"; - } else { - # same version declared multiple times, ignore - } - } else { - $file = $p->{file}; - $version = $p->{version}; - } + if ( defined( $version ) ) { + if ( $compare_versions->( $version, '!=', $p->{version} ) ) { + $err .= " $p->{file} ($p->{version})\n"; + } else { + # same version declared multiple times, ignore + } + } else { + $file = $p->{file}; + $version = $p->{version}; + } } - $file ||= $p->{file} if defined( $p->{file} ); - } + $file ||= $p->{file} if defined( $p->{file} ); + } if ( $err ) { $err = " $file ($version)\n" . $err; @@ -286,45 +287,45 @@ sub new_from_module { if ( exists( $prime{$package} ) ) { # primary package selected if ( $result->{err} ) { - # Use the selected primary package, but there are conflicting - # errors among multiple alternative packages that need to be - # reported + # Use the selected primary package, but there are conflicting + # errors among multiple alternative packages that need to be + # reported log_info { - "Found conflicting versions for package '$package'\n" . - " $prime{$package}{file} ($prime{$package}{version})\n" . - $result->{err} + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + $result->{err} }; } elsif ( defined( $result->{version} ) ) { - # There is a primary package selected, and exactly one - # alternative package - - if ( exists( $prime{$package}{version} ) && - defined( $prime{$package}{version} ) ) { - # Unless the version of the primary package agrees with the - # version of the alternative package, report a conflict - if ( $compare_versions->( + # There is a primary package selected, and exactly one + # alternative package + + if ( exists( $prime{$package}{version} ) && + defined( $prime{$package}{version} ) ) { + # Unless the version of the primary package agrees with the + # version of the alternative package, report a conflict + if ( $compare_versions->( $prime{$package}{version}, '!=', $result->{version} ) ) { log_info { "Found conflicting versions for package '$package'\n" . - " $prime{$package}{file} ($prime{$package}{version})\n" . - " $result->{file} ($result->{version})\n" + " $prime{$package}{file} ($prime{$package}{version})\n" . + " $result->{file} ($result->{version})\n" }; - } + } - } else { - # The prime package selected has no version so, we choose to - # use any alternative package that does have a version - $prime{$package}{file} = $result->{file}; - $prime{$package}{version} = $result->{version}; - } + } else { + # The prime package selected has no version so, we choose to + # use any alternative package that does have a version + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version}; + } } else { - # no alt package found with a version, but we have a prime - # package so we use it whether it has a version or not + # no alt package found with a version, but we have a prime + # package so we use it whether it has a version or not } } else { # No primary package was selected, use the best alternative @@ -332,7 +333,7 @@ sub new_from_module { if ( $result->{err} ) { log_info { "Found conflicting versions for package '$package'\n" . - $result->{err} + $result->{err} }; } @@ -340,12 +341,12 @@ sub new_from_module { # something rather than nothing $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version} - if defined( $result->{version} ); + if defined( $result->{version} ); } } # Normalize versions. Can't use exists() here because of bug in YAML::Node. - # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18 + # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 for (grep defined $_->{version}, values %prime) { $_->{version} = $normalize_version->( $_->{version} ); } @@ -422,9 +423,9 @@ sub _do_find_module { foreach my $dir ( @$dirs ) { my $testfile = File::Spec->catfile($dir, $file); return [ File::Spec->rel2abs( $testfile ), $dir ] - if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp + if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] - if -e "$testfile.pm"; + if -e "$testfile.pm"; } return; } @@ -539,15 +540,15 @@ sub _parse_fh { if ( $in_pod ) { if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { - push( @pod, $1 ); - if ( $self->{collect_pod} && length( $pod_data ) ) { + push( @pod, $1 ); + if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } - $pod_sect = $1; + $pod_sect = $1; } elsif ( $self->{collect_pod} ) { - $pod_data .= "$line\n"; + $pod_data .= "$line\n"; } @@ -588,43 +589,36 @@ sub _parse_fh { # VERSION defined with full package spec, i.e. $Module::VERSION } elsif ( $vers_fullname && $vers_pkg ) { - push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); - $need_vers = 0 if $vers_pkg eq $pkg; + push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); + $need_vers = 0 if $vers_pkg eq $pkg; - unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { - $vers{$vers_pkg} = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - } + unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { + $vers{$vers_pkg} = $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + } # first non-comment line in undeclared package main is VERSION } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { - $need_vers = 0; - my $v = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - $vers{$pkg} = $v; - push( @pkgs, 'main' ); + $need_vers = 0; + my $v = $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + $vers{$pkg} = $v; + push( @pkgs, 'main' ); # first non-comment line in undeclared package defines package main } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { - $need_vers = 1; - $vers{main} = ''; - push( @pkgs, 'main' ); + $need_vers = 1; + $vers{main} = ''; + push( @pkgs, 'main' ); # only keep if this is the first $VERSION seen } elsif ( $vers_fullname && $need_vers ) { - $need_vers = 0; - my $v = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - - - unless ( defined $vers{$pkg} && length $vers{$pkg} ) { - $vers{$pkg} = $v; - } + $need_vers = 0; + my $v = $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + unless ( defined $vers{$pkg} && length $vers{$pkg} ) { + $vers{$pkg} = $v; + } } - } - } if ( $self->{collect_pod} && length($pod_data) ) { @@ -649,10 +643,11 @@ sub _evaluate_version_line { # compiletime/runtime issues with local() my $vsub; $pn++; # everybody gets their own package - my $eval = qq{BEGIN { q# Hide from _packages_inside() + my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside() #; package Module::Metadata::_version::p$pn; use version; no strict; + no warnings; \$vsub = sub { local $sigil$var; @@ -662,6 +657,8 @@ sub _evaluate_version_line { }; }}; + $eval = $1 if $eval =~ m{^(.+)}s; + local $^W; # Try to get the $VERSION eval $eval; @@ -761,10 +758,10 @@ sub version { my $mod = shift || $self->{module}; my $vers; if ( defined( $mod ) && length( $mod ) && - exists( $self->{versions}{$mod} ) ) { - return $self->{versions}{$mod}; + exists( $self->{versions}{$mod} ) ) { + return $self->{versions}{$mod}; } else { - return undef; + return undef; } } @@ -772,13 +769,25 @@ sub pod { my $self = shift; my $sect = shift; if ( defined( $sect ) && length( $sect ) && - exists( $self->{pod}{$sect} ) ) { - return $self->{pod}{$sect}; + exists( $self->{pod}{$sect} ) ) { + return $self->{pod}{$sect}; } else { - return undef; + return undef; } } +sub is_indexable { + my ($self, $package) = @_; + + my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside; + + # check for specific package, if provided + return !! grep { $_ eq $package } @indexable_packages if $package; + + # otherwise, check for any indexable packages at all + return !! @indexable_packages; +} + 1; =head1 NAME @@ -800,8 +809,10 @@ Module::Metadata - Gather package and POD information from perl module files =head1 DESCRIPTION -This module provides a standard way to gather metadata about a .pm file -without executing unsafe code. +This module provides a standard way to gather metadata about a .pm file through +(mostly) static analysis and (some) code execution. When determining the +version of a module, the C<$VERSION> assignment is Ced, as is traditional +in the CPAN toolchain. =head1 USAGE @@ -950,7 +961,7 @@ Log::Contextual has already been loaded, otherwise simply calls warn. =item C<< name() >> Returns the name of the package represented by this module. If there -are more than one packages, it makes a best guess based on the +is more than one package, it makes a best guess based on the filename. If it's a script (i.e. not a *.pm) the package name is 'main'. @@ -987,6 +998,13 @@ Returns true if there is any POD in the file. Returns the POD data in the given section. +=item C<< is_indexable($package) >> or C<< is_indexable() >> + +Returns a boolean indicating whether the package (if provided) or any package +(otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server. +Note This only checks for valid C declarations, and does not take any +ownership information into account. + =back =head1 AUTHOR