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.000007';
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 $args{prefix} = 'lib' unless defined $args{prefix};
176 $p = $class->package_versions_from_directory($args{dir});
179 die "provides() requires 'files' to be an array reference\n"
180 unless ref $args{files} eq 'ARRAY';
181 $p = $class->package_versions_from_directory($args{files});
184 # Now, fix up files with prefix
185 if ( length $args{prefix} ) { # check in case disabled with q{}
186 $args{prefix} =~ s{/$}{};
187 for my $v ( values %$p ) {
188 $v->{file} = "$args{prefix}/$v->{file}";
195 sub package_versions_from_directory {
196 my ( $class, $dir, $files ) = @_;
205 push @files, $_ if -f $_ && /\.pm$/;
211 # First, we enumerate all packages & versions,
212 # separating into primary & alternative candidates
214 foreach my $file (@files) {
215 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
216 my @path = split( /\//, $mapped_filename );
217 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
219 my $pm_info = $class->new_from_file( $file );
221 foreach my $package ( $pm_info->packages_inside ) {
222 next if $package eq 'main'; # main can appear numerous times, ignore
223 next if $package eq 'DB'; # special debugging package, ignore
224 next if grep /^_/, split( /::/, $package ); # private package, ignore
226 my $version = $pm_info->version( $package );
228 if ( $package eq $prime_package ) {
229 if ( exists( $prime{$package} ) ) {
230 die "Unexpected conflict in '$package'; multiple versions found.\n";
232 $prime{$package}{file} = $mapped_filename;
233 $prime{$package}{version} = $version if defined( $version );
236 push( @{$alt{$package}}, {
237 file => $mapped_filename,
244 # Then we iterate over all the packages found above, identifying conflicts
245 # and selecting the "best" candidate for recording the file & version
247 foreach my $package ( keys( %alt ) ) {
248 my $result = $resolve_module_versions->( $alt{$package} );
250 if ( exists( $prime{$package} ) ) { # primary package selected
252 if ( $result->{err} ) {
253 # Use the selected primary package, but there are conflicting
254 # errors among multiple alternative packages that need to be
257 "Found conflicting versions for package '$package'\n" .
258 " $prime{$package}{file} ($prime{$package}{version})\n" .
262 } elsif ( defined( $result->{version} ) ) {
263 # There is a primary package selected, and exactly one
264 # alternative package
266 if ( exists( $prime{$package}{version} ) &&
267 defined( $prime{$package}{version} ) ) {
268 # Unless the version of the primary package agrees with the
269 # version of the alternative package, report a conflict
270 if ( $compare_versions->(
271 $prime{$package}{version}, '!=', $result->{version}
276 "Found conflicting versions for package '$package'\n" .
277 " $prime{$package}{file} ($prime{$package}{version})\n" .
278 " $result->{file} ($result->{version})\n"
283 # The prime package selected has no version so, we choose to
284 # use any alternative package that does have a version
285 $prime{$package}{file} = $result->{file};
286 $prime{$package}{version} = $result->{version};
290 # no alt package found with a version, but we have a prime
291 # package so we use it whether it has a version or not
294 } else { # No primary package was selected, use the best alternative
296 if ( $result->{err} ) {
298 "Found conflicting versions for package '$package'\n" .
303 # Despite possible conflicting versions, we choose to record
304 # something rather than nothing
305 $prime{$package}{file} = $result->{file};
306 $prime{$package}{version} = $result->{version}
307 if defined( $result->{version} );
311 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
312 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
313 for (grep defined $_->{version}, values %prime) {
314 $_->{version} = $normalize_version->( $_->{version} );
325 my $filename = shift;
328 my $handle = delete $props{handle};
329 my( %valid_props, @valid_props );
330 @valid_props = qw( collect_pod inc );
331 @valid_props{@valid_props} = delete( @props{@valid_props} );
332 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
336 filename => $filename,
347 my $self = bless(\%data, $class);
350 $self->_parse_fh($handle);
353 $self->_parse_file();
356 unless($self->{module} and length($self->{module})) {
357 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
360 my @candidates = grep /$f$/, @{$self->{packages}};
361 $self->{module} = shift(@candidates); # punt
364 if(grep /main/, @{$self->{packages}}) {
365 $self->{module} = 'main';
368 $self->{module} = $self->{packages}[0] || '';
373 $self->{version} = $self->{versions}{$self->{module}}
374 if defined( $self->{module} );
380 sub _do_find_module {
382 my $module = shift || die 'find_module_by_name() requires a package name';
383 my $dirs = shift || \@INC;
385 my $file = File::Spec->catfile(split( /::/, $module));
386 foreach my $dir ( @$dirs ) {
387 my $testfile = File::Spec->catfile($dir, $file);
388 return [ File::Spec->rel2abs( $testfile ), $dir ]
389 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
390 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
391 if -e "$testfile.pm";
397 sub find_module_by_name {
398 my $found = shift()->_do_find_module(@_) or return;
403 sub find_module_dir_by_name {
404 my $found = shift()->_do_find_module(@_) or return;
409 # given a line of perl code, attempt to parse it if it looks like a
410 # $VERSION assignment, returning sigil, full name, & package name
411 sub _parse_version_expression {
415 my( $sig, $var, $pkg );
416 if ( $line =~ $VERS_REGEXP ) {
417 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
419 $pkg = ($pkg eq '::') ? 'main' : $pkg;
424 return ( $sig, $var, $pkg );
430 my $filename = $self->{filename};
431 my $fh = IO::File->new( $filename )
432 or die( "Can't open '$filename': $!" );
434 $self->_parse_fh($fh);
438 my ($self, $fh) = @_;
440 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
441 my( @pkgs, %vers, %pod, @pod );
446 while (defined( my $line = <$fh> )) {
450 next if $line =~ /^\s*#/;
452 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
454 # Would be nice if we could also check $in_string or something too
455 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
457 if ( $in_pod || $line =~ /^=cut/ ) {
459 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
461 if ( $self->{collect_pod} && length( $pod_data ) ) {
462 $pod{$pod_sect} = $pod_data;
468 } elsif ( $self->{collect_pod} ) {
469 $pod_data .= "$line\n";
478 # parse $line to see if it's a $VERSION declaration
479 my( $vers_sig, $vers_fullname, $vers_pkg ) =
480 $self->_parse_version_expression( $line );
482 if ( $line =~ $PKG_REGEXP ) {
484 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
485 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
486 $need_vers = defined $2 ? 0 : 1;
488 # VERSION defined with full package spec, i.e. $Module::VERSION
489 } elsif ( $vers_fullname && $vers_pkg ) {
490 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
491 $need_vers = 0 if $vers_pkg eq $pkg;
493 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
495 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
497 # Warn unless the user is using the "$VERSION = eval
498 # $VERSION" idiom (though there are probably other idioms
499 # that we should watch out for...)
500 warn <<"EOM" unless $line =~ /=\s*eval/;
501 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
502 ignoring subsequent declaration on line $line_num.
506 # first non-comment line in undeclared package main is VERSION
507 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
510 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
512 push( @pkgs, 'main' );
514 # first non-comment line in undeclared package defines package main
515 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
518 push( @pkgs, 'main' );
520 # only keep if this is the first $VERSION seen
521 } elsif ( $vers_fullname && $need_vers ) {
524 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
527 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
531 Package '$pkg' already declared with version '$vers{$pkg}'
532 ignoring new version '$v' on line $line_num.
542 if ( $self->{collect_pod} && length($pod_data) ) {
543 $pod{$pod_sect} = $pod_data;
546 $self->{versions} = \%vers;
547 $self->{packages} = \@pkgs;
548 $self->{pod} = \%pod;
549 $self->{pod_headings} = \@pod;
554 sub _evaluate_version_line {
556 my( $sigil, $var, $line ) = @_;
558 # Some of this code came from the ExtUtils:: hierarchy.
560 # We compile into $vsub because 'use version' would cause
561 # compiletime/runtime issues with local()
563 $pn++; # everybody gets their own package
564 my $eval = qq{BEGIN { q# Hide from _packages_inside()
565 #; package Module::Metadata::_version::p$pn;
578 # Try to get the $VERSION
580 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
581 # installed, so we need to hunt in ./lib for it
582 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
583 local @INC = ('lib',@INC);
586 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
588 (ref($vsub) eq 'CODE') or
589 die "failed to build version sub for $self->{filename}";
590 my $result = eval { $vsub->() };
591 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
594 # Upgrade it into a version object
595 my $version = eval { _dwim_version($result) };
597 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
598 unless defined $version; # "0" is OK!
604 # Try to DWIM when things fail the lax version test in obvious ways
607 # Best case, it just works
608 sub { return shift },
610 # If we still don't have a version, try stripping any
611 # trailing junk that is prohibited by lax rules
614 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
618 # Activestate apparently creates custom versions like '1.23_45_01', which
619 # cause version.pm to think it's an invalid alpha. So check for that
623 my $num_dots = () = $v =~ m{(\.)}g;
624 my $num_unders = () = $v =~ m{(_)}g;
625 my $leading_v = substr($v,0,1) eq 'v';
626 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
628 $num_unders = () = $v =~ m{(_)}g;
633 # Worst case, try numifying it like we would have before version objects
636 no warnings 'numeric';
643 my ($result) = shift;
645 return $result if ref($result) eq 'version';
647 my ($version, $error);
648 for my $f (@version_prep) {
649 $result = $f->($result);
650 $version = eval { version->new($result) };
651 $error ||= $@ if $@; # capture first failure
652 last if defined $version;
655 die $error unless defined $version;
661 ############################################################
664 sub name { $_[0]->{module} }
666 sub filename { $_[0]->{filename} }
667 sub packages_inside { @{$_[0]->{packages}} }
668 sub pod_inside { @{$_[0]->{pod_headings}} }
669 sub contains_pod { $#{$_[0]->{pod_headings}} }
673 my $mod = shift || $self->{module};
675 if ( defined( $mod ) && length( $mod ) &&
676 exists( $self->{versions}{$mod} ) ) {
677 return $self->{versions}{$mod};
686 if ( defined( $sect ) && length( $sect ) &&
687 exists( $self->{pod}{$sect} ) ) {
688 return $self->{pod}{$sect};
698 Module::Metadata - Gather package and POD information from perl module files
702 use Module::Metadata;
704 # information about a .pm file
705 my $info = Module::Metadata->new_from_file( $file );
706 my $version = $info->version;
708 # CPAN META 'provides' field for .pm files in a directory
709 my $provides = Module::Metadata->provides(dir => 'lib');
713 This module provides a standard way to gather metadata about a .pm file
714 without executing unsafe code.
722 =item C<< new_from_file($filename, collect_pod => 1) >>
724 Construct a C<Module::Metadata> object given the path to a file. Takes an
725 optional argument C<collect_pod> which is a boolean that determines whether POD
726 data is collected and stored for reference. POD data is not collected by
727 default. POD headings are always collected. Returns undef if the filename
730 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
732 This works just like C<new_from_file>, except that a handle can be provided
733 as the first argument. Note that there is no validation to confirm that the
734 handle is a handle or something that can act like one. Passing something that
735 isn't a handle will cause a exception when trying to read from it. The
736 C<filename> argument is mandatory or undef will be returned.
738 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
740 Construct a C<Module::Metadata> object given a module or package name. In addition
741 to accepting the C<collect_pod> argument as described above, this
742 method accepts a C<inc> argument which is a reference to an array of
743 of directories to search for the module. If none are given, the
744 default is @INC. Returns undef if the module cannot be found.
746 =item C<< find_module_by_name($module, \@dirs) >>
748 Returns the path to a module given the module or package name. A list
749 of directories can be passed in as an optional parameter, otherwise
752 Can be called as either an object or a class method.
754 =item C<< find_module_dir_by_name($module, \@dirs) >>
756 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
757 the module C<$module>. A list of directories can be passed in as an
758 optional parameter, otherwise @INC is searched.
760 Can be called as either an object or a class method.
762 =item C<< provides( %options ) >>
764 This is a convenience wrapper around C<package_versions_from_directory>
765 to generate a CPAN META C<provides> data structure. It takes key/value
766 pairs. Valid option keys include:
772 Directory to search recursively for F<.pm> files. May not be specified with
777 Array reference of files to examine. May not be specified with C<dir>.
781 String to prepend to the C<file> field of the resulting output. This defaults
782 to F<lib>, which is the common case for most CPAN distributions with their
783 F<.pm> files in F<lib>. This option ensures the META information has the
784 correct relative path even when the C<dir> or C<files> arguments are
785 absolute or have relative paths from a location other than the distribution
790 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
791 is a hashref of the form:
796 file => 'lib/Package/Name.pm'
798 'OtherPackage::Name' => ...
801 =item C<< package_versions_from_directory($dir, \@files?) >>
803 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
804 for those files in C<$dir> - and reads each file for packages and versions,
805 returning a hashref of the form:
810 file => 'Package/Name.pm'
812 'OtherPackage::Name' => ...
815 The C<DB> and C<main> packages are always omitted, as are any "private"
816 packages that have leading underscores in the namespace (e.g.
819 Note that the file path is relative to C<$dir> if that is specified.
820 This B<must not> be used directly for CPAN META C<provides>. See
821 the C<provides> method instead.
823 =item C<< log_info (internal) >>
825 Used internally to perform logging; imported from Log::Contextual if
826 Log::Contextual has already been loaded, otherwise simply calls warn.
830 =head2 Object methods
836 Returns the name of the package represented by this module. If there
837 are more than one packages, it makes a best guess based on the
838 filename. If it's a script (i.e. not a *.pm) the package name is
841 =item C<< version($package) >>
843 Returns the version as defined by the $VERSION variable for the
844 package as returned by the C<name> method if no arguments are
845 given. If given the name of a package it will attempt to return the
846 version of that package if it is specified in the file.
848 =item C<< filename() >>
850 Returns the absolute path to the file.
852 =item C<< packages_inside() >>
854 Returns a list of packages.
856 =item C<< pod_inside() >>
858 Returns a list of POD sections.
860 =item C<< contains_pod() >>
862 Returns true if there is any POD in the file.
864 =item C<< pod($section) >>
866 Returns the POD data in the given section.
872 Original code from Module::Build::ModuleInfo by Ken Williams
873 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
875 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
876 assistance from David Golden (xdg) <dagolden@cpan.org>.
880 Original code Copyright (c) 2001-2011 Ken Williams.
881 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
884 This library is free software; you can redistribute it and/or
885 modify it under the same terms as Perl itself.