1 # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2 # vim:ts=8:sw=2:et:sta:sts=2
3 package Module::Metadata;
5 # Adapted from Perl-licensed code originally distributed with
6 # Module-Build by Ken Williams
8 # This module provides routines to gather information about
9 # perl modules (assuming this may be expanded in the distant
10 # parrot future to look at other types of modules).
13 use vars qw($VERSION);
14 $VERSION = '1.000008';
15 $VERSION = eval $VERSION;
22 if ($INC{'Log/Contextual.pm'}) {
23 Log::Contextual->import('log_info');
25 *log_info = sub (&) { warn $_[0]->() };
28 use File::Find qw(find);
30 my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
32 my $PKG_REGEXP = qr{ # match a package declaration
33 ^[\s\{;]* # intro chars on a line
34 package # the word 'package'
36 ([\w:]+) # a package name
37 \s* # optional whitespace
38 ($V_NUM_REGEXP)? # optional version number
39 \s* # optional whitesapce
40 [;\{] # semicolon line terminator or block start (since 5.16)
43 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
44 ([\$*]) # sigil - $ or *
46 ( # optional leading package name
47 (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
48 (?:\w+(?:::|\'))* # Foo::Bar:: ...
54 my $VERS_REGEXP = qr{ # match a VERSION definition
56 \(\s*$VARNAME_REGEXP\s*\) # with parens
58 $VARNAME_REGEXP # without parens
61 =[^=~] # = but not ==, nor =~
67 my $filename = File::Spec->rel2abs( shift );
69 return undef unless defined( $filename ) && -f $filename;
70 return $class->_init(undef, $filename, @_);
77 return undef unless defined($handle) && defined($filename);
78 $filename = File::Spec->rel2abs( $filename );
80 return $class->_init(undef, $filename, @_, handle => $handle);
90 $props{inc} ||= \@INC;
91 my $filename = $class->find_module_by_name( $module, $props{inc} );
92 return undef unless defined( $filename ) && -f $filename;
93 return $class->_init($module, $filename, %props);
98 my $compare_versions = sub {
99 my ($v1, $op, $v2) = @_;
100 $v1 = version->new($v1)
101 unless UNIVERSAL::isa($v1,'version');
103 my $eval_str = "\$v1 $op \$v2";
104 my $result = eval $eval_str;
105 log_info { "error comparing versions: '$eval_str' $@" } if $@;
110 my $normalize_version = sub {
112 if ( $version =~ /[=<>!,]/ ) { # logic, not just version
113 # take as is without modification
115 elsif ( ref $version eq 'version' ) { # version objects
116 $version = $version->is_qv ? $version->normal : $version->stringify;
118 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
119 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
120 $version = "v$version";
128 # separate out some of the conflict resolution logic
130 my $resolve_module_versions = sub {
131 my $packages = shift;
133 my( $file, $version );
135 foreach my $p ( @$packages ) {
136 if ( defined( $p->{version} ) ) {
137 if ( defined( $version ) ) {
138 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
139 $err .= " $p->{file} ($p->{version})\n";
141 # same version declared multiple times, ignore
145 $version = $p->{version};
148 $file ||= $p->{file} if defined( $p->{file} );
152 $err = " $file ($version)\n" . $err;
167 croak "provides() requires key/value pairs \n" if @_ % 2;
170 croak "provides() takes only one of 'dir' or 'files'\n"
171 if $args{dir} && $args{files};
173 croak "provides() requires a 'version' argument"
174 unless defined $args{version};
176 croak "provides() does not support version '$args{version}' metadata"
177 unless grep { $args{version} eq $_ } qw/1.4 2/;
179 $args{prefix} = 'lib' unless defined $args{prefix};
183 $p = $class->package_versions_from_directory($args{dir});
186 croak "provides() requires 'files' to be an array reference\n"
187 unless ref $args{files} eq 'ARRAY';
188 $p = $class->package_versions_from_directory($args{files});
191 # Now, fix up files with prefix
192 if ( length $args{prefix} ) { # check in case disabled with q{}
193 $args{prefix} =~ s{/$}{};
194 for my $v ( values %$p ) {
195 $v->{file} = "$args{prefix}/$v->{file}";
202 sub package_versions_from_directory {
203 my ( $class, $dir, $files ) = @_;
212 push @files, $_ if -f $_ && /\.pm$/;
218 # First, we enumerate all packages & versions,
219 # separating into primary & alternative candidates
221 foreach my $file (@files) {
222 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
223 my @path = split( /\//, $mapped_filename );
224 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
226 my $pm_info = $class->new_from_file( $file );
228 foreach my $package ( $pm_info->packages_inside ) {
229 next if $package eq 'main'; # main can appear numerous times, ignore
230 next if $package eq 'DB'; # special debugging package, ignore
231 next if grep /^_/, split( /::/, $package ); # private package, ignore
233 my $version = $pm_info->version( $package );
235 if ( $package eq $prime_package ) {
236 if ( exists( $prime{$package} ) ) {
237 croak "Unexpected conflict in '$package'; multiple versions found.\n";
239 $prime{$package}{file} = $mapped_filename;
240 $prime{$package}{version} = $version if defined( $version );
243 push( @{$alt{$package}}, {
244 file => $mapped_filename,
251 # Then we iterate over all the packages found above, identifying conflicts
252 # and selecting the "best" candidate for recording the file & version
254 foreach my $package ( keys( %alt ) ) {
255 my $result = $resolve_module_versions->( $alt{$package} );
257 if ( exists( $prime{$package} ) ) { # primary package selected
259 if ( $result->{err} ) {
260 # Use the selected primary package, but there are conflicting
261 # errors among multiple alternative packages that need to be
264 "Found conflicting versions for package '$package'\n" .
265 " $prime{$package}{file} ($prime{$package}{version})\n" .
269 } elsif ( defined( $result->{version} ) ) {
270 # There is a primary package selected, and exactly one
271 # alternative package
273 if ( exists( $prime{$package}{version} ) &&
274 defined( $prime{$package}{version} ) ) {
275 # Unless the version of the primary package agrees with the
276 # version of the alternative package, report a conflict
277 if ( $compare_versions->(
278 $prime{$package}{version}, '!=', $result->{version}
283 "Found conflicting versions for package '$package'\n" .
284 " $prime{$package}{file} ($prime{$package}{version})\n" .
285 " $result->{file} ($result->{version})\n"
290 # The prime package selected has no version so, we choose to
291 # use any alternative package that does have a version
292 $prime{$package}{file} = $result->{file};
293 $prime{$package}{version} = $result->{version};
297 # no alt package found with a version, but we have a prime
298 # package so we use it whether it has a version or not
301 } else { # No primary package was selected, use the best alternative
303 if ( $result->{err} ) {
305 "Found conflicting versions for package '$package'\n" .
310 # Despite possible conflicting versions, we choose to record
311 # something rather than nothing
312 $prime{$package}{file} = $result->{file};
313 $prime{$package}{version} = $result->{version}
314 if defined( $result->{version} );
318 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
319 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
320 for (grep defined $_->{version}, values %prime) {
321 $_->{version} = $normalize_version->( $_->{version} );
332 my $filename = shift;
335 my $handle = delete $props{handle};
336 my( %valid_props, @valid_props );
337 @valid_props = qw( collect_pod inc );
338 @valid_props{@valid_props} = delete( @props{@valid_props} );
339 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
343 filename => $filename,
354 my $self = bless(\%data, $class);
357 $self->_parse_fh($handle);
360 $self->_parse_file();
363 unless($self->{module} and length($self->{module})) {
364 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
367 my @candidates = grep /$f$/, @{$self->{packages}};
368 $self->{module} = shift(@candidates); # punt
371 if(grep /main/, @{$self->{packages}}) {
372 $self->{module} = 'main';
375 $self->{module} = $self->{packages}[0] || '';
380 $self->{version} = $self->{versions}{$self->{module}}
381 if defined( $self->{module} );
387 sub _do_find_module {
389 my $module = shift || croak 'find_module_by_name() requires a package name';
390 my $dirs = shift || \@INC;
392 my $file = File::Spec->catfile(split( /::/, $module));
393 foreach my $dir ( @$dirs ) {
394 my $testfile = File::Spec->catfile($dir, $file);
395 return [ File::Spec->rel2abs( $testfile ), $dir ]
396 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
397 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
398 if -e "$testfile.pm";
404 sub find_module_by_name {
405 my $found = shift()->_do_find_module(@_) or return;
410 sub find_module_dir_by_name {
411 my $found = shift()->_do_find_module(@_) or return;
416 # given a line of perl code, attempt to parse it if it looks like a
417 # $VERSION assignment, returning sigil, full name, & package name
418 sub _parse_version_expression {
422 my( $sig, $var, $pkg );
423 if ( $line =~ $VERS_REGEXP ) {
424 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
426 $pkg = ($pkg eq '::') ? 'main' : $pkg;
431 return ( $sig, $var, $pkg );
437 my $filename = $self->{filename};
438 my $fh = IO::File->new( $filename )
439 or croak( "Can't open '$filename': $!" );
441 $self->_parse_fh($fh);
445 my ($self, $fh) = @_;
447 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
448 my( @pkgs, %vers, %pod, @pod );
453 while (defined( my $line = <$fh> )) {
457 next if $line =~ /^\s*#/;
459 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
461 # Would be nice if we could also check $in_string or something too
462 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
464 if ( $in_pod || $line =~ /^=cut/ ) {
466 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
468 if ( $self->{collect_pod} && length( $pod_data ) ) {
469 $pod{$pod_sect} = $pod_data;
475 } elsif ( $self->{collect_pod} ) {
476 $pod_data .= "$line\n";
485 # parse $line to see if it's a $VERSION declaration
486 my( $vers_sig, $vers_fullname, $vers_pkg ) =
487 $self->_parse_version_expression( $line );
489 if ( $line =~ $PKG_REGEXP ) {
491 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
492 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
493 $need_vers = defined $2 ? 0 : 1;
495 # VERSION defined with full package spec, i.e. $Module::VERSION
496 } elsif ( $vers_fullname && $vers_pkg ) {
497 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
498 $need_vers = 0 if $vers_pkg eq $pkg;
500 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
502 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
504 # Warn unless the user is using the "$VERSION = eval
505 # $VERSION" idiom (though there are probably other idioms
506 # that we should watch out for...)
507 warn <<"EOM" unless $line =~ /=\s*eval/;
508 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
509 ignoring subsequent declaration on line $line_num.
513 # first non-comment line in undeclared package main is VERSION
514 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
517 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
519 push( @pkgs, 'main' );
521 # first non-comment line in undeclared package defines package main
522 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
525 push( @pkgs, 'main' );
527 # only keep if this is the first $VERSION seen
528 } elsif ( $vers_fullname && $need_vers ) {
531 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
534 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
538 Package '$pkg' already declared with version '$vers{$pkg}'
539 ignoring new version '$v' on line $line_num.
549 if ( $self->{collect_pod} && length($pod_data) ) {
550 $pod{$pod_sect} = $pod_data;
553 $self->{versions} = \%vers;
554 $self->{packages} = \@pkgs;
555 $self->{pod} = \%pod;
556 $self->{pod_headings} = \@pod;
561 sub _evaluate_version_line {
563 my( $sigil, $var, $line ) = @_;
565 # Some of this code came from the ExtUtils:: hierarchy.
567 # We compile into $vsub because 'use version' would cause
568 # compiletime/runtime issues with local()
570 $pn++; # everybody gets their own package
571 my $eval = qq{BEGIN { q# Hide from _packages_inside()
572 #; package Module::Metadata::_version::p$pn;
585 # Try to get the $VERSION
587 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
588 # installed, so we need to hunt in ./lib for it
589 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
590 local @INC = ('lib',@INC);
593 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
595 (ref($vsub) eq 'CODE') or
596 croak "failed to build version sub for $self->{filename}";
597 my $result = eval { $vsub->() };
598 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
601 # Upgrade it into a version object
602 my $version = eval { _dwim_version($result) };
604 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
605 unless defined $version; # "0" is OK!
611 # Try to DWIM when things fail the lax version test in obvious ways
614 # Best case, it just works
615 sub { return shift },
617 # If we still don't have a version, try stripping any
618 # trailing junk that is prohibited by lax rules
621 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
625 # Activestate apparently creates custom versions like '1.23_45_01', which
626 # cause version.pm to think it's an invalid alpha. So check for that
630 my $num_dots = () = $v =~ m{(\.)}g;
631 my $num_unders = () = $v =~ m{(_)}g;
632 my $leading_v = substr($v,0,1) eq 'v';
633 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
635 $num_unders = () = $v =~ m{(_)}g;
640 # Worst case, try numifying it like we would have before version objects
643 no warnings 'numeric';
650 my ($result) = shift;
652 return $result if ref($result) eq 'version';
654 my ($version, $error);
655 for my $f (@version_prep) {
656 $result = $f->($result);
657 $version = eval { version->new($result) };
658 $error ||= $@ if $@; # capture first failure
659 last if defined $version;
662 croak $error unless defined $version;
668 ############################################################
671 sub name { $_[0]->{module} }
673 sub filename { $_[0]->{filename} }
674 sub packages_inside { @{$_[0]->{packages}} }
675 sub pod_inside { @{$_[0]->{pod_headings}} }
676 sub contains_pod { $#{$_[0]->{pod_headings}} }
680 my $mod = shift || $self->{module};
682 if ( defined( $mod ) && length( $mod ) &&
683 exists( $self->{versions}{$mod} ) ) {
684 return $self->{versions}{$mod};
693 if ( defined( $sect ) && length( $sect ) &&
694 exists( $self->{pod}{$sect} ) ) {
695 return $self->{pod}{$sect};
705 Module::Metadata - Gather package and POD information from perl module files
709 use Module::Metadata;
711 # information about a .pm file
712 my $info = Module::Metadata->new_from_file( $file );
713 my $version = $info->version;
715 # CPAN META 'provides' field for .pm files in a directory
716 my $provides = Module::Metadata->provides(
717 dir => 'lib', version => 2
722 This module provides a standard way to gather metadata about a .pm file
723 without executing unsafe code.
731 =item C<< new_from_file($filename, collect_pod => 1) >>
733 Construct a C<Module::Metadata> object given the path to a file. Takes an
734 optional argument C<collect_pod> which is a boolean that determines whether POD
735 data is collected and stored for reference. POD data is not collected by
736 default. POD headings are always collected. Returns undef if the filename
739 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
741 This works just like C<new_from_file>, except that a handle can be provided
742 as the first argument. Note that there is no validation to confirm that the
743 handle is a handle or something that can act like one. Passing something that
744 isn't a handle will cause a exception when trying to read from it. The
745 C<filename> argument is mandatory or undef will be returned.
747 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
749 Construct a C<Module::Metadata> object given a module or package name. In addition
750 to accepting the C<collect_pod> argument as described above, this
751 method accepts a C<inc> argument which is a reference to an array of
752 of directories to search for the module. If none are given, the
753 default is @INC. Returns undef if the module cannot be found.
755 =item C<< find_module_by_name($module, \@dirs) >>
757 Returns the path to a module given the module or package name. A list
758 of directories can be passed in as an optional parameter, otherwise
761 Can be called as either an object or a class method.
763 =item C<< find_module_dir_by_name($module, \@dirs) >>
765 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
766 the module C<$module>. A list of directories can be passed in as an
767 optional parameter, otherwise @INC is searched.
769 Can be called as either an object or a class method.
771 =item C<< provides( %options ) >>
773 This is a convenience wrapper around C<package_versions_from_directory>
774 to generate a CPAN META C<provides> data structure. It takes key/value
775 pairs. Valid option keys include:
779 =item version B<(required)>
781 Specifies which version of the L<CPAN::Meta::Spec> should be used as
782 the format of the C<provides> output. Currently only '1.4' and '2'
783 are supported (and their format is identical). This may change in
784 the future as the definition of C<provides> changes.
786 The C<version> option is required. If it is omitted or if
787 an unsupported version is given, then C<provides> will throw an error.
791 Directory to search recursively for F<.pm> files. May not be specified with
796 Array reference of files to examine. May not be specified with C<dir>.
800 String to prepend to the C<file> field of the resulting output. This defaults
801 to F<lib>, which is the common case for most CPAN distributions with their
802 F<.pm> files in F<lib>. This option ensures the META information has the
803 correct relative path even when the C<dir> or C<files> arguments are
804 absolute or have relative paths from a location other than the distribution
809 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
810 is a hashref of the form:
815 file => 'lib/Package/Name.pm'
817 'OtherPackage::Name' => ...
820 =item C<< package_versions_from_directory($dir, \@files?) >>
822 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
823 for those files in C<$dir> - and reads each file for packages and versions,
824 returning a hashref of the form:
829 file => 'Package/Name.pm'
831 'OtherPackage::Name' => ...
834 The C<DB> and C<main> packages are always omitted, as are any "private"
835 packages that have leading underscores in the namespace (e.g.
838 Note that the file path is relative to C<$dir> if that is specified.
839 This B<must not> be used directly for CPAN META C<provides>. See
840 the C<provides> method instead.
842 =item C<< log_info (internal) >>
844 Used internally to perform logging; imported from Log::Contextual if
845 Log::Contextual has already been loaded, otherwise simply calls warn.
849 =head2 Object methods
855 Returns the name of the package represented by this module. If there
856 are more than one packages, it makes a best guess based on the
857 filename. If it's a script (i.e. not a *.pm) the package name is
860 =item C<< version($package) >>
862 Returns the version as defined by the $VERSION variable for the
863 package as returned by the C<name> method if no arguments are
864 given. If given the name of a package it will attempt to return the
865 version of that package if it is specified in the file.
867 =item C<< filename() >>
869 Returns the absolute path to the file.
871 =item C<< packages_inside() >>
873 Returns a list of packages. Note: this is a raw list of packages
874 discovered (or assumed, in the case of C<main>). It is not
875 filtered for C<DB>, C<main> or private packages the way the
876 C<provides> method does.
878 =item C<< pod_inside() >>
880 Returns a list of POD sections.
882 =item C<< contains_pod() >>
884 Returns true if there is any POD in the file.
886 =item C<< pod($section) >>
888 Returns the POD data in the given section.
894 Original code from Module::Build::ModuleInfo by Ken Williams
895 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
897 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
898 assistance from David Golden (xdg) <dagolden@cpan.org>.
902 Original code Copyright (c) 2001-2011 Ken Williams.
903 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
906 This library is free software; you can redistribute it and/or
907 modify it under the same terms as Perl itself.