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;
21 if ($INC{'Log/Contextual.pm'}) {
22 Log::Contextual->import('log_info');
24 *log_info = sub (&) { warn $_[0]->() };
27 use File::Find qw(find);
29 my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
31 my $PKG_REGEXP = qr{ # match a package declaration
32 ^[\s\{;]* # intro chars on a line
33 package # the word 'package'
35 ([\w:]+) # a package name
36 \s* # optional whitespace
37 ($V_NUM_REGEXP)? # optional version number
38 \s* # optional whitesapce
39 [;\{] # semicolon line terminator or block start (since 5.16)
42 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
43 ([\$*]) # sigil - $ or *
45 ( # optional leading package name
46 (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
47 (?:\w+(?:::|\'))* # Foo::Bar:: ...
53 my $VERS_REGEXP = qr{ # match a VERSION definition
55 \(\s*$VARNAME_REGEXP\s*\) # with parens
57 $VARNAME_REGEXP # without parens
60 =[^=~] # = but not ==, nor =~
66 my $filename = File::Spec->rel2abs( shift );
68 return undef unless defined( $filename ) && -f $filename;
69 return $class->_init(undef, $filename, @_);
76 return undef unless defined($handle) && defined($filename);
77 $filename = File::Spec->rel2abs( $filename );
79 return $class->_init(undef, $filename, @_, handle => $handle);
89 $props{inc} ||= \@INC;
90 my $filename = $class->find_module_by_name( $module, $props{inc} );
91 return undef unless defined( $filename ) && -f $filename;
92 return $class->_init($module, $filename, %props);
97 my $compare_versions = sub {
98 my ($v1, $op, $v2) = @_;
99 $v1 = version->new($v1)
100 unless UNIVERSAL::isa($v1,'version');
102 my $eval_str = "\$v1 $op \$v2";
103 my $result = eval $eval_str;
104 log_info { "error comparing versions: '$eval_str' $@" } if $@;
109 my $normalize_version = sub {
111 if ( $version =~ /[=<>!,]/ ) { # logic, not just version
112 # take as is without modification
114 elsif ( ref $version eq 'version' ) { # version objects
115 $version = $version->is_qv ? $version->normal : $version->stringify;
117 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
118 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
119 $version = "v$version";
127 # separate out some of the conflict resolution logic
129 my $resolve_module_versions = sub {
130 my $packages = shift;
132 my( $file, $version );
134 foreach my $p ( @$packages ) {
135 if ( defined( $p->{version} ) ) {
136 if ( defined( $version ) ) {
137 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
138 $err .= " $p->{file} ($p->{version})\n";
140 # same version declared multiple times, ignore
144 $version = $p->{version};
147 $file ||= $p->{file} if defined( $p->{file} );
151 $err = " $file ($version)\n" . $err;
166 die "provides() requires key/value pairs \n" if @_ % 2;
169 die "provides() takes only one of 'dir' or 'files'\n"
170 if $args{dir} && $args{files};
172 die "provides() requires a 'version' argument"
173 unless defined $args{version};
175 die "provides() does not support version '$args{version}' metadata"
176 unless grep { $args{version} eq $_ } qw/1.4 2/;
178 $args{prefix} = 'lib' unless defined $args{prefix};
182 $p = $class->package_versions_from_directory($args{dir});
185 die "provides() requires 'files' to be an array reference\n"
186 unless ref $args{files} eq 'ARRAY';
187 $p = $class->package_versions_from_directory($args{files});
190 # Now, fix up files with prefix
191 if ( length $args{prefix} ) { # check in case disabled with q{}
192 $args{prefix} =~ s{/$}{};
193 for my $v ( values %$p ) {
194 $v->{file} = "$args{prefix}/$v->{file}";
201 sub package_versions_from_directory {
202 my ( $class, $dir, $files ) = @_;
211 push @files, $_ if -f $_ && /\.pm$/;
217 # First, we enumerate all packages & versions,
218 # separating into primary & alternative candidates
220 foreach my $file (@files) {
221 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
222 my @path = split( /\//, $mapped_filename );
223 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
225 my $pm_info = $class->new_from_file( $file );
227 foreach my $package ( $pm_info->packages_inside ) {
228 next if $package eq 'main'; # main can appear numerous times, ignore
229 next if $package eq 'DB'; # special debugging package, ignore
230 next if grep /^_/, split( /::/, $package ); # private package, ignore
232 my $version = $pm_info->version( $package );
234 if ( $package eq $prime_package ) {
235 if ( exists( $prime{$package} ) ) {
236 die "Unexpected conflict in '$package'; multiple versions found.\n";
238 $prime{$package}{file} = $mapped_filename;
239 $prime{$package}{version} = $version if defined( $version );
242 push( @{$alt{$package}}, {
243 file => $mapped_filename,
250 # Then we iterate over all the packages found above, identifying conflicts
251 # and selecting the "best" candidate for recording the file & version
253 foreach my $package ( keys( %alt ) ) {
254 my $result = $resolve_module_versions->( $alt{$package} );
256 if ( exists( $prime{$package} ) ) { # primary package selected
258 if ( $result->{err} ) {
259 # Use the selected primary package, but there are conflicting
260 # errors among multiple alternative packages that need to be
263 "Found conflicting versions for package '$package'\n" .
264 " $prime{$package}{file} ($prime{$package}{version})\n" .
268 } elsif ( defined( $result->{version} ) ) {
269 # There is a primary package selected, and exactly one
270 # alternative package
272 if ( exists( $prime{$package}{version} ) &&
273 defined( $prime{$package}{version} ) ) {
274 # Unless the version of the primary package agrees with the
275 # version of the alternative package, report a conflict
276 if ( $compare_versions->(
277 $prime{$package}{version}, '!=', $result->{version}
282 "Found conflicting versions for package '$package'\n" .
283 " $prime{$package}{file} ($prime{$package}{version})\n" .
284 " $result->{file} ($result->{version})\n"
289 # The prime package selected has no version so, we choose to
290 # use any alternative package that does have a version
291 $prime{$package}{file} = $result->{file};
292 $prime{$package}{version} = $result->{version};
296 # no alt package found with a version, but we have a prime
297 # package so we use it whether it has a version or not
300 } else { # No primary package was selected, use the best alternative
302 if ( $result->{err} ) {
304 "Found conflicting versions for package '$package'\n" .
309 # Despite possible conflicting versions, we choose to record
310 # something rather than nothing
311 $prime{$package}{file} = $result->{file};
312 $prime{$package}{version} = $result->{version}
313 if defined( $result->{version} );
317 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
318 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
319 for (grep defined $_->{version}, values %prime) {
320 $_->{version} = $normalize_version->( $_->{version} );
331 my $filename = shift;
334 my $handle = delete $props{handle};
335 my( %valid_props, @valid_props );
336 @valid_props = qw( collect_pod inc );
337 @valid_props{@valid_props} = delete( @props{@valid_props} );
338 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
342 filename => $filename,
353 my $self = bless(\%data, $class);
356 $self->_parse_fh($handle);
359 $self->_parse_file();
362 unless($self->{module} and length($self->{module})) {
363 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
366 my @candidates = grep /$f$/, @{$self->{packages}};
367 $self->{module} = shift(@candidates); # punt
370 if(grep /main/, @{$self->{packages}}) {
371 $self->{module} = 'main';
374 $self->{module} = $self->{packages}[0] || '';
379 $self->{version} = $self->{versions}{$self->{module}}
380 if defined( $self->{module} );
386 sub _do_find_module {
388 my $module = shift || die 'find_module_by_name() requires a package name';
389 my $dirs = shift || \@INC;
391 my $file = File::Spec->catfile(split( /::/, $module));
392 foreach my $dir ( @$dirs ) {
393 my $testfile = File::Spec->catfile($dir, $file);
394 return [ File::Spec->rel2abs( $testfile ), $dir ]
395 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
396 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
397 if -e "$testfile.pm";
403 sub find_module_by_name {
404 my $found = shift()->_do_find_module(@_) or return;
409 sub find_module_dir_by_name {
410 my $found = shift()->_do_find_module(@_) or return;
415 # given a line of perl code, attempt to parse it if it looks like a
416 # $VERSION assignment, returning sigil, full name, & package name
417 sub _parse_version_expression {
421 my( $sig, $var, $pkg );
422 if ( $line =~ $VERS_REGEXP ) {
423 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
425 $pkg = ($pkg eq '::') ? 'main' : $pkg;
430 return ( $sig, $var, $pkg );
436 my $filename = $self->{filename};
437 my $fh = IO::File->new( $filename )
438 or die( "Can't open '$filename': $!" );
440 $self->_parse_fh($fh);
444 my ($self, $fh) = @_;
446 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
447 my( @pkgs, %vers, %pod, @pod );
452 while (defined( my $line = <$fh> )) {
456 next if $line =~ /^\s*#/;
458 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
460 # Would be nice if we could also check $in_string or something too
461 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
463 if ( $in_pod || $line =~ /^=cut/ ) {
465 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
467 if ( $self->{collect_pod} && length( $pod_data ) ) {
468 $pod{$pod_sect} = $pod_data;
474 } elsif ( $self->{collect_pod} ) {
475 $pod_data .= "$line\n";
484 # parse $line to see if it's a $VERSION declaration
485 my( $vers_sig, $vers_fullname, $vers_pkg ) =
486 $self->_parse_version_expression( $line );
488 if ( $line =~ $PKG_REGEXP ) {
490 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
491 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
492 $need_vers = defined $2 ? 0 : 1;
494 # VERSION defined with full package spec, i.e. $Module::VERSION
495 } elsif ( $vers_fullname && $vers_pkg ) {
496 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
497 $need_vers = 0 if $vers_pkg eq $pkg;
499 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
501 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
503 # Warn unless the user is using the "$VERSION = eval
504 # $VERSION" idiom (though there are probably other idioms
505 # that we should watch out for...)
506 warn <<"EOM" unless $line =~ /=\s*eval/;
507 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
508 ignoring subsequent declaration on line $line_num.
512 # first non-comment line in undeclared package main is VERSION
513 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
516 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
518 push( @pkgs, 'main' );
520 # first non-comment line in undeclared package defines package main
521 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
524 push( @pkgs, 'main' );
526 # only keep if this is the first $VERSION seen
527 } elsif ( $vers_fullname && $need_vers ) {
530 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
533 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
537 Package '$pkg' already declared with version '$vers{$pkg}'
538 ignoring new version '$v' on line $line_num.
548 if ( $self->{collect_pod} && length($pod_data) ) {
549 $pod{$pod_sect} = $pod_data;
552 $self->{versions} = \%vers;
553 $self->{packages} = \@pkgs;
554 $self->{pod} = \%pod;
555 $self->{pod_headings} = \@pod;
560 sub _evaluate_version_line {
562 my( $sigil, $var, $line ) = @_;
564 # Some of this code came from the ExtUtils:: hierarchy.
566 # We compile into $vsub because 'use version' would cause
567 # compiletime/runtime issues with local()
569 $pn++; # everybody gets their own package
570 my $eval = qq{BEGIN { q# Hide from _packages_inside()
571 #; package Module::Metadata::_version::p$pn;
584 # Try to get the $VERSION
586 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
587 # installed, so we need to hunt in ./lib for it
588 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
589 local @INC = ('lib',@INC);
592 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
594 (ref($vsub) eq 'CODE') or
595 die "failed to build version sub for $self->{filename}";
596 my $result = eval { $vsub->() };
597 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
600 # Upgrade it into a version object
601 my $version = eval { _dwim_version($result) };
603 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
604 unless defined $version; # "0" is OK!
610 # Try to DWIM when things fail the lax version test in obvious ways
613 # Best case, it just works
614 sub { return shift },
616 # If we still don't have a version, try stripping any
617 # trailing junk that is prohibited by lax rules
620 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
624 # Activestate apparently creates custom versions like '1.23_45_01', which
625 # cause version.pm to think it's an invalid alpha. So check for that
629 my $num_dots = () = $v =~ m{(\.)}g;
630 my $num_unders = () = $v =~ m{(_)}g;
631 my $leading_v = substr($v,0,1) eq 'v';
632 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
634 $num_unders = () = $v =~ m{(_)}g;
639 # Worst case, try numifying it like we would have before version objects
642 no warnings 'numeric';
649 my ($result) = shift;
651 return $result if ref($result) eq 'version';
653 my ($version, $error);
654 for my $f (@version_prep) {
655 $result = $f->($result);
656 $version = eval { version->new($result) };
657 $error ||= $@ if $@; # capture first failure
658 last if defined $version;
661 die $error unless defined $version;
667 ############################################################
670 sub name { $_[0]->{module} }
672 sub filename { $_[0]->{filename} }
673 sub packages_inside { @{$_[0]->{packages}} }
674 sub pod_inside { @{$_[0]->{pod_headings}} }
675 sub contains_pod { $#{$_[0]->{pod_headings}} }
679 my $mod = shift || $self->{module};
681 if ( defined( $mod ) && length( $mod ) &&
682 exists( $self->{versions}{$mod} ) ) {
683 return $self->{versions}{$mod};
692 if ( defined( $sect ) && length( $sect ) &&
693 exists( $self->{pod}{$sect} ) ) {
694 return $self->{pod}{$sect};
704 Module::Metadata - Gather package and POD information from perl module files
708 use Module::Metadata;
710 # information about a .pm file
711 my $info = Module::Metadata->new_from_file( $file );
712 my $version = $info->version;
714 # CPAN META 'provides' field for .pm files in a directory
715 my $provides = Module::Metadata->provides(
716 dir => 'lib', version => 2
721 This module provides a standard way to gather metadata about a .pm file
722 without executing unsafe code.
730 =item C<< new_from_file($filename, collect_pod => 1) >>
732 Construct a C<Module::Metadata> object given the path to a file. Takes an
733 optional argument C<collect_pod> which is a boolean that determines whether POD
734 data is collected and stored for reference. POD data is not collected by
735 default. POD headings are always collected. Returns undef if the filename
738 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
740 This works just like C<new_from_file>, except that a handle can be provided
741 as the first argument. Note that there is no validation to confirm that the
742 handle is a handle or something that can act like one. Passing something that
743 isn't a handle will cause a exception when trying to read from it. The
744 C<filename> argument is mandatory or undef will be returned.
746 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
748 Construct a C<Module::Metadata> object given a module or package name. In addition
749 to accepting the C<collect_pod> argument as described above, this
750 method accepts a C<inc> argument which is a reference to an array of
751 of directories to search for the module. If none are given, the
752 default is @INC. Returns undef if the module cannot be found.
754 =item C<< find_module_by_name($module, \@dirs) >>
756 Returns the path to a module given the module or package name. A list
757 of directories can be passed in as an optional parameter, otherwise
760 Can be called as either an object or a class method.
762 =item C<< find_module_dir_by_name($module, \@dirs) >>
764 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
765 the module C<$module>. A list of directories can be passed in as an
766 optional parameter, otherwise @INC is searched.
768 Can be called as either an object or a class method.
770 =item C<< provides( %options ) >>
772 This is a convenience wrapper around C<package_versions_from_directory>
773 to generate a CPAN META C<provides> data structure. It takes key/value
774 pairs. Valid option keys include:
778 =item version B<(required)>
780 Specifies which version of the L<CPAN::Meta::Spec> should be used as
781 the format of the C<provides> output. Currently only '1.4' and '2'
782 are supported (and their format is identical). This may change in
783 the future as the definition of C<provides> changes.
785 The C<version> option is required. If it is omitted or if
786 an unsupported version is given, then C<provides> will throw an error.
790 Directory to search recursively for F<.pm> files. May not be specified with
795 Array reference of files to examine. May not be specified with C<dir>.
799 String to prepend to the C<file> field of the resulting output. This defaults
800 to F<lib>, which is the common case for most CPAN distributions with their
801 F<.pm> files in F<lib>. This option ensures the META information has the
802 correct relative path even when the C<dir> or C<files> arguments are
803 absolute or have relative paths from a location other than the distribution
808 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
809 is a hashref of the form:
814 file => 'lib/Package/Name.pm'
816 'OtherPackage::Name' => ...
819 =item C<< package_versions_from_directory($dir, \@files?) >>
821 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
822 for those files in C<$dir> - and reads each file for packages and versions,
823 returning a hashref of the form:
828 file => 'Package/Name.pm'
830 'OtherPackage::Name' => ...
833 The C<DB> and C<main> packages are always omitted, as are any "private"
834 packages that have leading underscores in the namespace (e.g.
837 Note that the file path is relative to C<$dir> if that is specified.
838 This B<must not> be used directly for CPAN META C<provides>. See
839 the C<provides> method instead.
841 =item C<< log_info (internal) >>
843 Used internally to perform logging; imported from Log::Contextual if
844 Log::Contextual has already been loaded, otherwise simply calls warn.
848 =head2 Object methods
854 Returns the name of the package represented by this module. If there
855 are more than one packages, it makes a best guess based on the
856 filename. If it's a script (i.e. not a *.pm) the package name is
859 =item C<< version($package) >>
861 Returns the version as defined by the $VERSION variable for the
862 package as returned by the C<name> method if no arguments are
863 given. If given the name of a package it will attempt to return the
864 version of that package if it is specified in the file.
866 =item C<< filename() >>
868 Returns the absolute path to the file.
870 =item C<< packages_inside() >>
872 Returns a list of packages. Note: this is a raw list of packages
873 discovered (or assumed, in the case of C<main>). It is not
874 filtered for C<DB>, C<main> or private packages the way the
875 C<provides> method does.
877 =item C<< pod_inside() >>
879 Returns a list of POD sections.
881 =item C<< contains_pod() >>
883 Returns true if there is any POD in the file.
885 =item C<< pod($section) >>
887 Returns the POD data in the given section.
893 Original code from Module::Build::ModuleInfo by Ken Williams
894 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
896 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
897 assistance from David Golden (xdg) <dagolden@cpan.org>.
901 Original code Copyright (c) 2001-2011 Ken Williams.
902 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
905 This library is free software; you can redistribute it and/or
906 modify it under the same terms as Perl itself.