X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FModule%2FMetadata.pm;h=514dd1c16ea6593d39442dcbc6b38b43ab55ccf1;hb=6290f67cbac16f68d0c2b536fa9d5457230e2e41;hp=fe027b799e05fdb2aa415c710c83f6fb1798ee47;hpb=3db2701705c9f302b3d08e721ff2a907c07b4f90;p=p5sagit%2FModule-Metadata.git diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm index fe027b7..514dd1c 100644 --- a/lib/Module/Metadata.pm +++ b/lib/Module/Metadata.pm @@ -2,8 +2,8 @@ # vim:ts=8:sw=2:et:sta:sts=2 package Module::Metadata; -# stolen from Module::Build::Version and ::Base - this is perl licensed code, -# copyright them. +# Adapted from Perl-licensed code originally distributed with +# Module-Build by Ken Williams # This module provides routines to gather information about # perl modules (assuming this may be expanded in the distant @@ -11,17 +11,17 @@ package Module::Metadata; use strict; use vars qw($VERSION); -$VERSION = '0.36_04'; +$VERSION = '1.000005'; $VERSION = eval $VERSION; use File::Spec; use IO::File; -use Module::Metadata::Version; +use version 0.87; BEGIN { if ($INC{'Log/Contextual.pm'}) { Log::Contextual->import('log_info'); } else { - *log_info = sub { warn @_ }; + *log_info = sub (&) { warn $_[0]->() }; } } use File::Find qw(find); @@ -69,6 +69,18 @@ sub new_from_file { return $class->_init(undef, $filename, @_); } +sub new_from_handle { + my $class = shift; + my $handle = shift; + my $filename = shift; + return undef unless defined($handle) && defined($filename); + $filename = File::Spec->rel2abs( $filename ); + + return $class->_init(undef, $filename, @_, handle => $handle); + +} + + sub new_from_module { my $class = shift; my $module = shift; @@ -84,8 +96,8 @@ sub new_from_module { my $compare_versions = sub { my ($v1, $op, $v2) = @_; - $v1 = Module::Metadata::Version->new($v1) - unless UNIVERSAL::isa($v1,'Module::Metadata::Version'); + $v1 = version->new($v1) + unless UNIVERSAL::isa($v1,'version'); my $eval_str = "\$v1 $op \$v2"; my $result = eval $eval_str; @@ -99,8 +111,7 @@ sub new_from_module { if ( $version =~ /[=<>!,]/ ) { # logic, not just version # take as is without modification } - elsif ( ref $version eq 'version' || - ref $version eq 'Module::Metadata::Version' ) { # version objects + elsif ( ref $version eq 'version' ) { # version objects $version = $version->is_qv ? $version->normal : $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots @@ -184,7 +195,6 @@ sub new_from_module { if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { - # M::B::ModuleInfo will handle this conflict die "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $prime{$package}{file} = $mapped_filename; @@ -283,6 +293,7 @@ sub _init { my $filename = shift; my %props = @_; + my $handle = delete $props{handle}; my( %valid_props, @valid_props ); @valid_props = qw( collect_pod inc ); @valid_props{@valid_props} = delete( @props{@valid_props} ); @@ -303,7 +314,12 @@ sub _init { my $self = bless(\%data, $class); - $self->_parse_file(); + if ( $handle ) { + $self->_parse_fh($handle); + } + else { + $self->_parse_file(); + } unless($self->{module} and length($self->{module})) { my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); @@ -515,12 +531,12 @@ sub _evaluate_version_line { $pn++; # everybody gets their own package my $eval = qq{BEGIN { q# Hide from _packages_inside() #; package Module::Metadata::_version::p$pn; - use Module::Metadata::Version; + use version; no strict; - local $sigil$var; - \$$var=undef; \$vsub = sub { + local $sigil$var; + \$$var=undef; $line; \$$var }; @@ -543,24 +559,72 @@ sub _evaluate_version_line { die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@; - # Activestate apparently creates custom versions like '1.23_45_01', which - # cause M::B::Version to think it's an invalid alpha. So check for that - # and strip them - my $num_dots = () = $result =~ m{\.}g; - my $num_unders = () = $result =~ m{_}g; - if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) { - $result =~ s{_}{}g; - } + # Upgrade it into a version object + my $version = eval { _dwim_version($result) }; - # Bless it into our own version class - eval { $result = Module::Metadata::Version->new($result) }; die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" - if $@; + unless defined $version; # "0" is OK! - return $result; + return $version; } } +# Try to DWIM when things fail the lax version test in obvious ways +{ + my @version_prep = ( + # Best case, it just works + sub { return shift }, + + # If we still don't have a version, try stripping any + # trailing junk that is prohibited by lax rules + sub { + my $v = shift; + $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b + return $v; + }, + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause version.pm to think it's an invalid alpha. So check for that + # and strip them + sub { + my $v = shift; + my $num_dots = () = $v =~ m{(\.)}g; + my $num_unders = () = $v =~ m{(_)}g; + my $leading_v = substr($v,0,1) eq 'v'; + if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { + $v =~ s{_}{}g; + $num_unders = () = $v =~ m{(_)}g; + } + return $v; + }, + + # Worst case, try numifying it like we would have before version objects + sub { + my $v = shift; + no warnings 'numeric'; + return 0 + $v; + }, + + ); + + sub _dwim_version { + my ($result) = shift; + + return $result if ref($result) eq 'version'; + + my ($version, $error); + for my $f (@version_prep) { + $result = $f->($result); + $version = eval { version->new($result) }; + $error ||= $@ if $@; # capture first failure + last if defined $version; + } + + die $error unless defined $version; + + return $version; + } +} ############################################################ @@ -597,103 +661,150 @@ sub pod { 1; -__END__ +=head1 NAME -=for :stopwords ModuleInfo +Module::Metadata - Gather package and POD information from perl module files -=head1 NAME +=head1 SYNOPSIS -ModuleInfo - Gather package and POD information from a perl module file + use Module::Metadata; + # information about a .pm file + my $info = Module::Metadata->new_from_file( $file ); + my $version = $info->version; + + # information about a directory full of .pm files + my $provides = + Module::Metadata->package_versions_from_directory('lib'); =head1 DESCRIPTION +This module provides a standard way to gather metadata about a .pm file +without executing unsafe code. + +=head1 USAGE + +=head2 Class methods + =over 4 -=item new_from_file($filename, collect_pod => 1) +=item C<< new_from_file($filename, collect_pod => 1) >> + +Construct a C object given the path to a file. Takes an +optional argument C which is a boolean that determines whether POD +data is collected and stored for reference. POD data is not collected by +default. POD headings are always collected. Returns undef if the filename +does not exist. -Construct a C object given the path to a file. Takes an optional -argument C which is a boolean that determines whether -POD data is collected and stored for reference. POD data is not -collected by default. POD headings are always collected. +=item C<< new_from_handle($handle, $filename, collect_pod => 1) >> -=item new_from_module($module, collect_pod => 1, inc => \@dirs) +This works just like C, except that a handle can be provided +as the first argument. Note that there is no validation to confirm that the +handle is a handle or something that can act like one. Passing something that +isn't a handle will cause a exception when trying to read from it. The +C argument is mandatory or undef will be returned. -Construct a C object given a module or package name. In addition +=item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >> + +Construct a C object given a module or package name. In addition to accepting the C argument as described above, this method accepts a C argument which is a reference to an array of of directories to search for the module. If none are given, the -default is @INC. +default is @INC. Returns undef if the module cannot be found. + +=item C<< find_module_by_name($module, \@dirs) >> + +Returns the path to a module given the module or package name. A list +of directories can be passed in as an optional parameter, otherwise +@INC is searched. -=item name() +Can be called as either an object or a class method. + +=item C<< find_module_dir_by_name($module, \@dirs) >> + +Returns the entry in C<@dirs> (or C<@INC> by default) that contains +the module C<$module>. A list of directories can be passed in as an +optional parameter, otherwise @INC is searched. + +Can be called as either an object or a class method. + +=item C<< package_versions_from_directory($dir, \@files?) >> + +Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks +for those files in C<$dir> - and reads each file for packages and versions, +returning a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + +=item C<< log_info (internal) >> + +Used internally to perform logging; imported from Log::Contextual if +Log::Contextual has already been loaded, otherwise simply calls warn. + +=back + +=head2 Object methods + +=over 4 + +=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 filename. If it's a script (i.e. not a *.pm) the package name is 'main'. -=item version($package) +=item C<< version($package) >> Returns the version as defined by the $VERSION variable for the package as returned by the C method if no arguments are given. If given the name of a package it will attempt to return the version of that package if it is specified in the file. -=item filename() +=item C<< filename() >> Returns the absolute path to the file. -=item packages_inside() +=item C<< packages_inside() >> Returns a list of packages. -=item pod_inside() +=item C<< pod_inside() >> Returns a list of POD sections. -=item contains_pod() +=item C<< contains_pod() >> Returns true if there is any POD in the file. -=item pod($section) +=item C<< pod($section) >> Returns the POD data in the given section. -=item find_module_by_name($module, \@dirs) - -Returns the path to a module given the module or package name. A list -of directories can be passed in as an optional parameter, otherwise -@INC is searched. - -Can be called as either an object or a class method. - -=item find_module_dir_by_name($module, \@dirs) - -Returns the entry in C<@dirs> (or C<@INC> by default) that contains -the module C<$module>. A list of directories can be passed in as an -optional parameter, otherwise @INC is searched. - -Can be called as either an object or a class method. - =back - =head1 AUTHOR -Ken Williams , Randy W. Sims +Original code from Module::Build::ModuleInfo by Ken Williams +, Randy W. Sims +Released as Module::Metadata by Matt S Trout (mst) with +assistance from David Golden (xdg) . =head1 COPYRIGHT -Copyright (c) 2001-2006 Ken Williams. All rights reserved. +Original code Copyright (c) 2001-2011 Ken Williams. +Additional code Copyright (c) 2010-2011 Matt Trout and David Golden. +All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -perl(1), L(3) - =cut