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.000010';
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::Unix->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 $prime_package = $package if lc($prime_package) eq lc($package);
236 if ( $package eq $prime_package ) {
237 if ( exists( $prime{$package} ) ) {
238 croak "Unexpected conflict in '$package'; multiple versions found.\n";
240 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
241 $prime{$package}{file} = $mapped_filename;
242 $prime{$package}{version} = $version if defined( $version );
245 push( @{$alt{$package}}, {
246 file => $mapped_filename,
253 # Then we iterate over all the packages found above, identifying conflicts
254 # and selecting the "best" candidate for recording the file & version
256 foreach my $package ( keys( %alt ) ) {
257 my $result = $resolve_module_versions->( $alt{$package} );
259 if ( exists( $prime{$package} ) ) { # primary package selected
261 if ( $result->{err} ) {
262 # Use the selected primary package, but there are conflicting
263 # errors among multiple alternative packages that need to be
266 "Found conflicting versions for package '$package'\n" .
267 " $prime{$package}{file} ($prime{$package}{version})\n" .
271 } elsif ( defined( $result->{version} ) ) {
272 # There is a primary package selected, and exactly one
273 # alternative package
275 if ( exists( $prime{$package}{version} ) &&
276 defined( $prime{$package}{version} ) ) {
277 # Unless the version of the primary package agrees with the
278 # version of the alternative package, report a conflict
279 if ( $compare_versions->(
280 $prime{$package}{version}, '!=', $result->{version}
285 "Found conflicting versions for package '$package'\n" .
286 " $prime{$package}{file} ($prime{$package}{version})\n" .
287 " $result->{file} ($result->{version})\n"
292 # The prime package selected has no version so, we choose to
293 # use any alternative package that does have a version
294 $prime{$package}{file} = $result->{file};
295 $prime{$package}{version} = $result->{version};
299 # no alt package found with a version, but we have a prime
300 # package so we use it whether it has a version or not
303 } else { # No primary package was selected, use the best alternative
305 if ( $result->{err} ) {
307 "Found conflicting versions for package '$package'\n" .
312 # Despite possible conflicting versions, we choose to record
313 # something rather than nothing
314 $prime{$package}{file} = $result->{file};
315 $prime{$package}{version} = $result->{version}
316 if defined( $result->{version} );
320 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
321 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
322 for (grep defined $_->{version}, values %prime) {
323 $_->{version} = $normalize_version->( $_->{version} );
334 my $filename = shift;
337 my $handle = delete $props{handle};
338 my( %valid_props, @valid_props );
339 @valid_props = qw( collect_pod inc );
340 @valid_props{@valid_props} = delete( @props{@valid_props} );
341 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
345 filename => $filename,
356 my $self = bless(\%data, $class);
359 $self->_parse_fh($handle);
362 $self->_parse_file();
365 unless($self->{module} and length($self->{module})) {
366 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
369 my @candidates = grep /$f$/, @{$self->{packages}};
370 $self->{module} = shift(@candidates); # punt
373 if(grep /main/, @{$self->{packages}}) {
374 $self->{module} = 'main';
377 $self->{module} = $self->{packages}[0] || '';
382 $self->{version} = $self->{versions}{$self->{module}}
383 if defined( $self->{module} );
389 sub _do_find_module {
391 my $module = shift || croak 'find_module_by_name() requires a package name';
392 my $dirs = shift || \@INC;
394 my $file = File::Spec->catfile(split( /::/, $module));
395 foreach my $dir ( @$dirs ) {
396 my $testfile = File::Spec->catfile($dir, $file);
397 return [ File::Spec->rel2abs( $testfile ), $dir ]
398 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
399 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
400 if -e "$testfile.pm";
406 sub find_module_by_name {
407 my $found = shift()->_do_find_module(@_) or return;
412 sub find_module_dir_by_name {
413 my $found = shift()->_do_find_module(@_) or return;
418 # given a line of perl code, attempt to parse it if it looks like a
419 # $VERSION assignment, returning sigil, full name, & package name
420 sub _parse_version_expression {
424 my( $sig, $var, $pkg );
425 if ( $line =~ /$VERS_REGEXP/o ) {
426 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
428 $pkg = ($pkg eq '::') ? 'main' : $pkg;
433 return ( $sig, $var, $pkg );
439 my $filename = $self->{filename};
440 my $fh = IO::File->new( $filename )
441 or croak( "Can't open '$filename': $!" );
443 $self->_parse_fh($fh);
447 my ($self, $fh) = @_;
449 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
450 my( @pkgs, %vers, %pod, @pod );
455 while (defined( my $line = <$fh> )) {
459 next if $line =~ /^\s*#/;
462 if ( $line =~ /^=(.{0,3})/ ) {
463 $is_cut = $1 eq 'cut';
467 # Would be nice if we could also check $in_string or something too
468 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
470 if ( $in_pod || $is_cut ) {
472 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
474 if ( $self->{collect_pod} && length( $pod_data ) ) {
475 $pod{$pod_sect} = $pod_data;
481 } elsif ( $self->{collect_pod} ) {
482 $pod_data .= "$line\n";
491 # parse $line to see if it's a $VERSION declaration
492 my( $vers_sig, $vers_fullname, $vers_pkg ) =
494 ? $self->_parse_version_expression( $line )
497 if ( $line =~ /$PKG_REGEXP/o ) {
499 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
500 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
501 $need_vers = defined $2 ? 0 : 1;
503 # VERSION defined with full package spec, i.e. $Module::VERSION
504 } elsif ( $vers_fullname && $vers_pkg ) {
505 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
506 $need_vers = 0 if $vers_pkg eq $pkg;
508 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
510 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
512 # Warn unless the user is using the "$VERSION = eval
513 # $VERSION" idiom (though there are probably other idioms
514 # that we should watch out for...)
515 warn <<"EOM" unless $line =~ /=\s*eval/;
516 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
517 ignoring subsequent declaration on line $line_num.
521 # first non-comment line in undeclared package main is VERSION
522 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
525 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
527 push( @pkgs, 'main' );
529 # first non-comment line in undeclared package defines package main
530 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
533 push( @pkgs, 'main' );
535 # only keep if this is the first $VERSION seen
536 } elsif ( $vers_fullname && $need_vers ) {
539 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
542 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
546 Package '$pkg' already declared with version '$vers{$pkg}'
547 ignoring new version '$v' on line $line_num.
557 if ( $self->{collect_pod} && length($pod_data) ) {
558 $pod{$pod_sect} = $pod_data;
561 $self->{versions} = \%vers;
562 $self->{packages} = \@pkgs;
563 $self->{pod} = \%pod;
564 $self->{pod_headings} = \@pod;
569 sub _evaluate_version_line {
571 my( $sigil, $var, $line ) = @_;
573 # Some of this code came from the ExtUtils:: hierarchy.
575 # We compile into $vsub because 'use version' would cause
576 # compiletime/runtime issues with local()
578 $pn++; # everybody gets their own package
579 my $eval = qq{BEGIN { q# Hide from _packages_inside()
580 #; package Module::Metadata::_version::p$pn;
593 # Try to get the $VERSION
595 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
596 # installed, so we need to hunt in ./lib for it
597 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
598 local @INC = ('lib',@INC);
601 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
603 (ref($vsub) eq 'CODE') or
604 croak "failed to build version sub for $self->{filename}";
605 my $result = eval { $vsub->() };
606 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
609 # Upgrade it into a version object
610 my $version = eval { _dwim_version($result) };
612 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
613 unless defined $version; # "0" is OK!
619 # Try to DWIM when things fail the lax version test in obvious ways
622 # Best case, it just works
623 sub { return shift },
625 # If we still don't have a version, try stripping any
626 # trailing junk that is prohibited by lax rules
629 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
633 # Activestate apparently creates custom versions like '1.23_45_01', which
634 # cause version.pm to think it's an invalid alpha. So check for that
638 my $num_dots = () = $v =~ m{(\.)}g;
639 my $num_unders = () = $v =~ m{(_)}g;
640 my $leading_v = substr($v,0,1) eq 'v';
641 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
643 $num_unders = () = $v =~ m{(_)}g;
648 # Worst case, try numifying it like we would have before version objects
651 no warnings 'numeric';
658 my ($result) = shift;
660 return $result if ref($result) eq 'version';
662 my ($version, $error);
663 for my $f (@version_prep) {
664 $result = $f->($result);
665 $version = eval { version->new($result) };
666 $error ||= $@ if $@; # capture first failure
667 last if defined $version;
670 croak $error unless defined $version;
676 ############################################################
679 sub name { $_[0]->{module} }
681 sub filename { $_[0]->{filename} }
682 sub packages_inside { @{$_[0]->{packages}} }
683 sub pod_inside { @{$_[0]->{pod_headings}} }
684 sub contains_pod { $#{$_[0]->{pod_headings}} }
688 my $mod = shift || $self->{module};
690 if ( defined( $mod ) && length( $mod ) &&
691 exists( $self->{versions}{$mod} ) ) {
692 return $self->{versions}{$mod};
701 if ( defined( $sect ) && length( $sect ) &&
702 exists( $self->{pod}{$sect} ) ) {
703 return $self->{pod}{$sect};
713 Module::Metadata - Gather package and POD information from perl module files
717 use Module::Metadata;
719 # information about a .pm file
720 my $info = Module::Metadata->new_from_file( $file );
721 my $version = $info->version;
723 # CPAN META 'provides' field for .pm files in a directory
724 my $provides = Module::Metadata->provides(
725 dir => 'lib', version => 2
730 This module provides a standard way to gather metadata about a .pm file
731 without executing unsafe code.
739 =item C<< new_from_file($filename, collect_pod => 1) >>
741 Construct a C<Module::Metadata> object given the path to a file. Takes an
742 optional argument C<collect_pod> which is a boolean that determines whether POD
743 data is collected and stored for reference. POD data is not collected by
744 default. POD headings are always collected. Returns undef if the filename
747 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
749 This works just like C<new_from_file>, except that a handle can be provided
750 as the first argument. Note that there is no validation to confirm that the
751 handle is a handle or something that can act like one. Passing something that
752 isn't a handle will cause a exception when trying to read from it. The
753 C<filename> argument is mandatory or undef will be returned.
755 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
757 Construct a C<Module::Metadata> object given a module or package name. In addition
758 to accepting the C<collect_pod> argument as described above, this
759 method accepts a C<inc> argument which is a reference to an array of
760 of directories to search for the module. If none are given, the
761 default is @INC. Returns undef if the module cannot be found.
763 =item C<< find_module_by_name($module, \@dirs) >>
765 Returns the path to a module given the module or package name. A list
766 of directories can be passed in as an optional parameter, otherwise
769 Can be called as either an object or a class method.
771 =item C<< find_module_dir_by_name($module, \@dirs) >>
773 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
774 the module C<$module>. A list of directories can be passed in as an
775 optional parameter, otherwise @INC is searched.
777 Can be called as either an object or a class method.
779 =item C<< provides( %options ) >>
781 This is a convenience wrapper around C<package_versions_from_directory>
782 to generate a CPAN META C<provides> data structure. It takes key/value
783 pairs. Valid option keys include:
787 =item version B<(required)>
789 Specifies which version of the L<CPAN::Meta::Spec> should be used as
790 the format of the C<provides> output. Currently only '1.4' and '2'
791 are supported (and their format is identical). This may change in
792 the future as the definition of C<provides> changes.
794 The C<version> option is required. If it is omitted or if
795 an unsupported version is given, then C<provides> will throw an error.
799 Directory to search recursively for F<.pm> files. May not be specified with
804 Array reference of files to examine. May not be specified with C<dir>.
808 String to prepend to the C<file> field of the resulting output. This defaults
809 to F<lib>, which is the common case for most CPAN distributions with their
810 F<.pm> files in F<lib>. This option ensures the META information has the
811 correct relative path even when the C<dir> or C<files> arguments are
812 absolute or have relative paths from a location other than the distribution
817 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
818 is a hashref of the form:
823 file => 'lib/Package/Name.pm'
825 'OtherPackage::Name' => ...
828 =item C<< package_versions_from_directory($dir, \@files?) >>
830 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
831 for those files in C<$dir> - and reads each file for packages and versions,
832 returning a hashref of the form:
837 file => 'Package/Name.pm'
839 'OtherPackage::Name' => ...
842 The C<DB> and C<main> packages are always omitted, as are any "private"
843 packages that have leading underscores in the namespace (e.g.
846 Note that the file path is relative to C<$dir> if that is specified.
847 This B<must not> be used directly for CPAN META C<provides>. See
848 the C<provides> method instead.
850 =item C<< log_info (internal) >>
852 Used internally to perform logging; imported from Log::Contextual if
853 Log::Contextual has already been loaded, otherwise simply calls warn.
857 =head2 Object methods
863 Returns the name of the package represented by this module. If there
864 are more than one packages, it makes a best guess based on the
865 filename. If it's a script (i.e. not a *.pm) the package name is
868 =item C<< version($package) >>
870 Returns the version as defined by the $VERSION variable for the
871 package as returned by the C<name> method if no arguments are
872 given. If given the name of a package it will attempt to return the
873 version of that package if it is specified in the file.
875 =item C<< filename() >>
877 Returns the absolute path to the file.
879 =item C<< packages_inside() >>
881 Returns a list of packages. Note: this is a raw list of packages
882 discovered (or assumed, in the case of C<main>). It is not
883 filtered for C<DB>, C<main> or private packages the way the
884 C<provides> method does.
886 =item C<< pod_inside() >>
888 Returns a list of POD sections.
890 =item C<< contains_pod() >>
892 Returns true if there is any POD in the file.
894 =item C<< pod($section) >>
896 Returns the POD data in the given section.
902 Original code from Module::Build::ModuleInfo by Ken Williams
903 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
905 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
906 assistance from David Golden (xdg) <dagolden@cpan.org>.
910 Original code Copyright (c) 2001-2011 Ken Williams.
911 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
914 This library is free software; you can redistribute it and/or
915 modify it under the same terms as Perl itself.