X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FModule%2FMetadata.pm;h=4fad0f36c1dd27dc00143244e0638f896582f90c;hb=921abefc6515ee816ce328eba4ac604e37d89752;hp=6541f1e55398a7d5ead3e01ae97eb69110357088;hpb=f9335daa3890217043463ba87a0440fec43c4b89;p=p5sagit%2FModule-Metadata.git diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm index 6541f1e..4fad0f3 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,9 +11,10 @@ package Module::Metadata; use strict; use vars qw($VERSION); -$VERSION = '1.000002'; +$VERSION = '1.000009'; $VERSION = eval $VERSION; +use Carp qw/croak/; use File::Spec; use IO::File; use version 0.87; @@ -36,7 +37,7 @@ my $PKG_REGEXP = qr{ # match a package declaration \s* # optional whitespace ($V_NUM_REGEXP)? # optional version number \s* # optional whitesapce - ; # semicolon line terminator + [;\{] # semicolon line terminator or block start (since 5.16) }x; my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name @@ -69,6 +70,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; @@ -148,6 +161,44 @@ sub new_from_module { return \%result; }; + sub provides { + my $class = shift; + + croak "provides() requires key/value pairs \n" if @_ % 2; + my %args = @_; + + croak "provides() takes only one of 'dir' or 'files'\n" + if $args{dir} && $args{files}; + + croak "provides() requires a 'version' argument" + unless defined $args{version}; + + croak "provides() does not support version '$args{version}' metadata" + unless grep { $args{version} eq $_ } qw/1.4 2/; + + $args{prefix} = 'lib' unless defined $args{prefix}; + + my $p; + if ( $args{dir} ) { + $p = $class->package_versions_from_directory($args{dir}); + } + else { + croak "provides() requires 'files' to be an array reference\n" + unless ref $args{files} eq 'ARRAY'; + $p = $class->package_versions_from_directory($args{files}); + } + + # Now, fix up files with prefix + if ( length $args{prefix} ) { # check in case disabled with q{} + $args{prefix} =~ s{/$}{}; + for my $v ( values %$p ) { + $v->{file} = "$args{prefix}/$v->{file}"; + } + } + + return $p + } + sub package_versions_from_directory { my ( $class, $dir, $files ) = @_; @@ -183,8 +234,7 @@ 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"; + croak "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); @@ -282,6 +332,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} ); @@ -302,7 +353,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}); @@ -330,7 +386,7 @@ sub _init { # class method sub _do_find_module { my $class = shift; - my $module = shift || die 'find_module_by_name() requires a package name'; + my $module = shift || croak 'find_module_by_name() requires a package name'; my $dirs = shift || \@INC; my $file = File::Spec->catfile(split( /::/, $module)); @@ -380,7 +436,7 @@ sub _parse_file { my $filename = $self->{filename}; my $fh = IO::File->new( $filename ) - or die( "Can't open '$filename': $!" ); + or croak( "Can't open '$filename': $!" ); $self->_parse_fh($fh); } @@ -400,12 +456,16 @@ sub _parse_fh { chomp( $line ); next if $line =~ /^\s*#/; - $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; + my $is_cut; + if ( $line =~ /^=(.{0,3})/ ) { + $is_cut = $1 eq 'cut'; + $in_pod = !$is_cut; + } # Would be nice if we could also check $in_string or something too last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; - if ( $in_pod || $line =~ /^=cut/ ) { + if ( $in_pod || $is_cut ) { if ( $line =~ /^=head\d\s+(.+)\s*$/ ) { push( @pod, $1 ); @@ -517,9 +577,9 @@ sub _evaluate_version_line { use version; no strict; - local $sigil$var; - \$$var=undef; \$vsub = sub { + local $sigil$var; + \$$var=undef; $line; \$$var }; @@ -537,15 +597,15 @@ sub _evaluate_version_line { warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@; (ref($vsub) eq 'CODE') or - die "failed to build version sub for $self->{filename}"; + croak "failed to build version sub for $self->{filename}"; my $result = eval { $vsub->() }; - die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" + croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@; # Upgrade it into a version object my $version = eval { _dwim_version($result) }; - die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined $version; # "0" is OK! return $version; @@ -603,7 +663,7 @@ sub _evaluate_version_line { last if defined $version; } - die $error unless defined $version; + croak $error unless defined $version; return $version; } @@ -648,76 +708,120 @@ sub pod { Module::Metadata - Gather package and POD information from perl module files +=head1 SYNOPSIS + + use Module::Metadata; + + # information about a .pm file + my $info = Module::Metadata->new_from_file( $file ); + my $version = $info->version; + + # CPAN META 'provides' field for .pm files in a directory + my $provides = Module::Metadata->provides( + dir => 'lib', version => 2 + ); + =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 name() +=item C<< find_module_by_name($module, \@dirs) >> -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'. +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 version($package) +Can be called as either an object or a class method. -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 C<< find_module_dir_by_name($module, \@dirs) >> -=item filename() +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. -Returns the absolute path to the file. +Can be called as either an object or a class method. -=item packages_inside() +=item C<< provides( %options ) >> -Returns a list of packages. +This is a convenience wrapper around C +to generate a CPAN META C data structure. It takes key/value +pairs. Valid option keys include: -=item pod_inside() +=over -Returns a list of POD sections. +=item version B<(required)> -=item contains_pod() +Specifies which version of the L should be used as +the format of the C output. Currently only '1.4' and '2' +are supported (and their format is identical). This may change in +the future as the definition of C changes. -Returns true if there is any POD in the file. +The C option is required. If it is omitted or if +an unsupported version is given, then C will throw an error. -=item pod($section) +=item dir -Returns the POD data in the given section. +Directory to search recursively for F<.pm> files. May not be specified with +C. -=item find_module_by_name($module, \@dirs) +=item files -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. +Array reference of files to examine. May not be specified with C. -Can be called as either an object or a class method. +=item prefix -=item find_module_dir_by_name($module, \@dirs) +String to prepend to the C field of the resulting output. This defaults +to F, which is the common case for most CPAN distributions with their +F<.pm> files in F. This option ensures the META information has the +correct relative path even when the C or C arguments are +absolute or have relative paths from a location other than the distribution +root. -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. +=back -Can be called as either an object or a class method. +For example, given C of 'lib' and C of 'lib', the return value +is a hashref of the form: -=item package_versions_from_directory($dir, \@files?) + { + 'Package::Name' => { + version => '0.123', + file => 'lib/Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + +=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, @@ -731,30 +835,80 @@ returning a hashref of the form: 'OtherPackage::Name' => ... } -=item log_info (internal) +The C and C
packages are always omitted, as are any "private" +packages that have leading underscores in the namespace (e.g. +C) + +Note that the file path is relative to C<$dir> if that is specified. +This B be used directly for CPAN META C. See +the C method instead. + +=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 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 C<< filename() >> + +Returns the absolute path to the file. + +=item C<< packages_inside() >> + +Returns a list of packages. Note: this is a raw list of packages +discovered (or assumed, in the case of C
). It is not +filtered for C, C
or private packages the way the +C method does. + +=item C<< pod_inside() >> + +Returns a list of POD sections. + +=item C<< contains_pod() >> + +Returns true if there is any POD in the file. + +=item C<< pod($section) >> + +Returns the POD data in the given section. + +=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) +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