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 =~
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 croak "provides() requires key/value pairs \n" if @_ % 2;
169 croak "provides() takes only one of 'dir' or 'files'\n"
170 if $args{dir} && $args{files};
172 croak "provides() requires a 'version' argument"
173 unless defined $args{version};
175 croak "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 croak "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::Unix->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 $prime_package = $package if lc($prime_package) eq lc($package);
235 if ( $package eq $prime_package ) {
236 if ( exists( $prime{$package} ) ) {
237 croak "Unexpected conflict in '$package'; multiple versions found.\n";
239 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
240 $prime{$package}{file} = $mapped_filename;
241 $prime{$package}{version} = $version if defined( $version );
244 push( @{$alt{$package}}, {
245 file => $mapped_filename,
252 # Then we iterate over all the packages found above, identifying conflicts
253 # and selecting the "best" candidate for recording the file & version
255 foreach my $package ( keys( %alt ) ) {
256 my $result = $resolve_module_versions->( $alt{$package} );
258 if ( exists( $prime{$package} ) ) { # primary package selected
260 if ( $result->{err} ) {
261 # Use the selected primary package, but there are conflicting
262 # errors among multiple alternative packages that need to be
265 "Found conflicting versions for package '$package'\n" .
266 " $prime{$package}{file} ($prime{$package}{version})\n" .
270 } elsif ( defined( $result->{version} ) ) {
271 # There is a primary package selected, and exactly one
272 # alternative package
274 if ( exists( $prime{$package}{version} ) &&
275 defined( $prime{$package}{version} ) ) {
276 # Unless the version of the primary package agrees with the
277 # version of the alternative package, report a conflict
278 if ( $compare_versions->(
279 $prime{$package}{version}, '!=', $result->{version}
284 "Found conflicting versions for package '$package'\n" .
285 " $prime{$package}{file} ($prime{$package}{version})\n" .
286 " $result->{file} ($result->{version})\n"
291 # The prime package selected has no version so, we choose to
292 # use any alternative package that does have a version
293 $prime{$package}{file} = $result->{file};
294 $prime{$package}{version} = $result->{version};
298 # no alt package found with a version, but we have a prime
299 # package so we use it whether it has a version or not
302 } else { # No primary package was selected, use the best alternative
304 if ( $result->{err} ) {
306 "Found conflicting versions for package '$package'\n" .
311 # Despite possible conflicting versions, we choose to record
312 # something rather than nothing
313 $prime{$package}{file} = $result->{file};
314 $prime{$package}{version} = $result->{version}
315 if defined( $result->{version} );
319 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
320 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
321 for (grep defined $_->{version}, values %prime) {
322 $_->{version} = $normalize_version->( $_->{version} );
333 my $filename = shift;
336 my $handle = delete $props{handle};
337 my( %valid_props, @valid_props );
338 @valid_props = qw( collect_pod inc );
339 @valid_props{@valid_props} = delete( @props{@valid_props} );
340 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
344 filename => $filename,
355 my $self = bless(\%data, $class);
358 $self->_parse_fh($handle);
361 $self->_parse_file();
364 unless($self->{module} and length($self->{module})) {
365 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
368 my @candidates = grep /$f$/, @{$self->{packages}};
369 $self->{module} = shift(@candidates); # punt
372 if(grep /main/, @{$self->{packages}}) {
373 $self->{module} = 'main';
376 $self->{module} = $self->{packages}[0] || '';
381 $self->{version} = $self->{versions}{$self->{module}}
382 if defined( $self->{module} );
388 sub _do_find_module {
390 my $module = shift || croak 'find_module_by_name() requires a package name';
391 my $dirs = shift || \@INC;
393 my $file = File::Spec->catfile(split( /::/, $module));
394 foreach my $dir ( @$dirs ) {
395 my $testfile = File::Spec->catfile($dir, $file);
396 return [ File::Spec->rel2abs( $testfile ), $dir ]
397 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
398 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
399 if -e "$testfile.pm";
405 sub find_module_by_name {
406 my $found = shift()->_do_find_module(@_) or return;
411 sub find_module_dir_by_name {
412 my $found = shift()->_do_find_module(@_) or return;
417 # given a line of perl code, attempt to parse it if it looks like a
418 # $VERSION assignment, returning sigil, full name, & package name
419 sub _parse_version_expression {
423 my( $sig, $var, $pkg );
424 if ( $line =~ /$VERS_REGEXP/o ) {
425 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
427 $pkg = ($pkg eq '::') ? 'main' : $pkg;
432 return ( $sig, $var, $pkg );
438 my $filename = $self->{filename};
439 my $fh = IO::File->new( $filename )
440 or croak( "Can't open '$filename': $!" );
442 $self->_handle_bom($fh, $filename);
444 $self->_parse_fh($fh);
447 # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
448 # If there's one, then skip it and set the :encoding layer appropriately.
450 my ($self, $fh, $filename) = @_;
452 my $pos = $fh->getpos;
453 return unless defined $pos;
456 my $count = $fh->read( $buf, length $buf );
457 return unless defined $count and $count >= 2;
460 if ( $buf eq "\x{FE}\x{FF}" ) {
461 $encoding = 'UTF-16BE';
462 } elsif ( $buf eq "\x{FF}\x{FE}" ) {
463 $encoding = 'UTF-16LE';
464 } elsif ( $buf eq "\x{EF}\x{BB}" ) {
466 $count = $fh->read( $buf, length $buf );
467 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
472 if ( defined $encoding ) {
473 if ( "$]" >= 5.008 ) {
474 # $fh->binmode requires perl 5.10
475 binmode( $fh, ":encoding($encoding)" );
479 or croak( sprintf "Can't reset position to the top of '$filename'" );
486 my ($self, $fh) = @_;
488 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
489 my( @pkgs, %vers, %pod, @pod );
494 while (defined( my $line = <$fh> )) {
499 # From toke.c : any line that begins by "=X", where X is an alphabetic
500 # character, introduces a POD segment.
502 if ( $line =~ /^=([a-zA-Z].*)/ ) {
504 # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
505 # character (which includes the newline, but here we chomped it away).
506 $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
510 # Would be nice if we could also check $in_string or something too
511 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
515 if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
517 if ( $self->{collect_pod} && length( $pod_data ) ) {
518 $pod{$pod_sect} = $pod_data;
523 } elsif ( $self->{collect_pod} ) {
524 $pod_data .= "$line\n";
528 } elsif ( $is_cut ) {
530 if ( $self->{collect_pod} && length( $pod_data ) ) {
531 $pod{$pod_sect} = $pod_data;
538 # Skip comments in code
539 next if $line =~ /^\s*#/;
541 # parse $line to see if it's a $VERSION declaration
542 my( $vers_sig, $vers_fullname, $vers_pkg ) =
544 ? $self->_parse_version_expression( $line )
547 if ( $line =~ /$PKG_REGEXP/o ) {
549 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
550 $vers{$pkg} = $2 unless exists( $vers{$pkg} );
551 $need_vers = defined $2 ? 0 : 1;
553 # VERSION defined with full package spec, i.e. $Module::VERSION
554 } elsif ( $vers_fullname && $vers_pkg ) {
555 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
556 $need_vers = 0 if $vers_pkg eq $pkg;
558 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
560 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
562 # Warn unless the user is using the "$VERSION = eval
563 # $VERSION" idiom (though there are probably other idioms
564 # that we should watch out for...)
565 warn <<"EOM" unless $line =~ /=\s*eval/;
566 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
567 ignoring subsequent declaration on line $line_num.
571 # first non-comment line in undeclared package main is VERSION
572 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
575 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
577 push( @pkgs, 'main' );
579 # first non-comment line in undeclared package defines package main
580 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
583 push( @pkgs, 'main' );
585 # only keep if this is the first $VERSION seen
586 } elsif ( $vers_fullname && $need_vers ) {
589 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
592 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
596 Package '$pkg' already declared with version '$vers{$pkg}'
597 ignoring new version '$v' on line $line_num.
607 if ( $self->{collect_pod} && length($pod_data) ) {
608 $pod{$pod_sect} = $pod_data;
611 $self->{versions} = \%vers;
612 $self->{packages} = \@pkgs;
613 $self->{pod} = \%pod;
614 $self->{pod_headings} = \@pod;
619 sub _evaluate_version_line {
621 my( $sigil, $var, $line ) = @_;
623 # Some of this code came from the ExtUtils:: hierarchy.
625 # We compile into $vsub because 'use version' would cause
626 # compiletime/runtime issues with local()
628 $pn++; # everybody gets their own package
629 my $eval = qq{BEGIN { q# Hide from _packages_inside()
630 #; package Module::Metadata::_version::p$pn;
643 # Try to get the $VERSION
645 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
646 # installed, so we need to hunt in ./lib for it
647 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
648 local @INC = ('lib',@INC);
651 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
653 (ref($vsub) eq 'CODE') or
654 croak "failed to build version sub for $self->{filename}";
655 my $result = eval { $vsub->() };
656 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
659 # Upgrade it into a version object
660 my $version = eval { _dwim_version($result) };
662 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
663 unless defined $version; # "0" is OK!
669 # Try to DWIM when things fail the lax version test in obvious ways
672 # Best case, it just works
673 sub { return shift },
675 # If we still don't have a version, try stripping any
676 # trailing junk that is prohibited by lax rules
679 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
683 # Activestate apparently creates custom versions like '1.23_45_01', which
684 # cause version.pm to think it's an invalid alpha. So check for that
688 my $num_dots = () = $v =~ m{(\.)}g;
689 my $num_unders = () = $v =~ m{(_)}g;
690 my $leading_v = substr($v,0,1) eq 'v';
691 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
693 $num_unders = () = $v =~ m{(_)}g;
698 # Worst case, try numifying it like we would have before version objects
701 no warnings 'numeric';
708 my ($result) = shift;
710 return $result if ref($result) eq 'version';
712 my ($version, $error);
713 for my $f (@version_prep) {
714 $result = $f->($result);
715 $version = eval { version->new($result) };
716 $error ||= $@ if $@; # capture first failure
717 last if defined $version;
720 croak $error unless defined $version;
726 ############################################################
729 sub name { $_[0]->{module} }
731 sub filename { $_[0]->{filename} }
732 sub packages_inside { @{$_[0]->{packages}} }
733 sub pod_inside { @{$_[0]->{pod_headings}} }
734 sub contains_pod { $#{$_[0]->{pod_headings}} }
738 my $mod = shift || $self->{module};
740 if ( defined( $mod ) && length( $mod ) &&
741 exists( $self->{versions}{$mod} ) ) {
742 return $self->{versions}{$mod};
751 if ( defined( $sect ) && length( $sect ) &&
752 exists( $self->{pod}{$sect} ) ) {
753 return $self->{pod}{$sect};
763 Module::Metadata - Gather package and POD information from perl module files
767 use Module::Metadata;
769 # information about a .pm file
770 my $info = Module::Metadata->new_from_file( $file );
771 my $version = $info->version;
773 # CPAN META 'provides' field for .pm files in a directory
774 my $provides = Module::Metadata->provides(
775 dir => 'lib', version => 2
780 This module provides a standard way to gather metadata about a .pm file
781 without executing unsafe code.
789 =item C<< new_from_file($filename, collect_pod => 1) >>
791 Constructs a C<Module::Metadata> object given the path to a file. Returns
792 undef if the filename does not exist.
794 C<collect_pod> is a optional boolean argument that determines whether POD
795 data is collected and stored for reference. POD data is not collected by
796 default. POD headings are always collected.
798 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
799 it is skipped before processing, and the content of the file is also decoded
800 appropriately starting from perl 5.8.
802 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
804 This works just like C<new_from_file>, except that a handle can be provided
805 as the first argument.
807 Note that there is no validation to confirm that the handle is a handle or
808 something that can act like one. Passing something that isn't a handle will
809 cause a exception when trying to read from it. The C<filename> argument is
810 mandatory or undef will be returned.
812 You are responsible for setting the decoding layers on C<$handle> if
815 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
817 Constructs a C<Module::Metadata> object given a module or package name.
818 Returns undef if the module cannot be found.
820 In addition to accepting the C<collect_pod> argument as described above,
821 this method accepts a C<inc> argument which is a reference to an array of
822 directories to search for the module. If none are given, the default is
825 If the file that contains the module begins by an UTF-8, UTF-16BE or
826 UTF-16LE byte-order mark, then it is skipped before processing, and the
827 content of the file is also decoded appropriately starting from perl 5.8.
829 =item C<< find_module_by_name($module, \@dirs) >>
831 Returns the path to a module given the module or package name. A list
832 of directories can be passed in as an optional parameter, otherwise
835 Can be called as either an object or a class method.
837 =item C<< find_module_dir_by_name($module, \@dirs) >>
839 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
840 the module C<$module>. A list of directories can be passed in as an
841 optional parameter, otherwise @INC is searched.
843 Can be called as either an object or a class method.
845 =item C<< provides( %options ) >>
847 This is a convenience wrapper around C<package_versions_from_directory>
848 to generate a CPAN META C<provides> data structure. It takes key/value
849 pairs. Valid option keys include:
853 =item version B<(required)>
855 Specifies which version of the L<CPAN::Meta::Spec> should be used as
856 the format of the C<provides> output. Currently only '1.4' and '2'
857 are supported (and their format is identical). This may change in
858 the future as the definition of C<provides> changes.
860 The C<version> option is required. If it is omitted or if
861 an unsupported version is given, then C<provides> will throw an error.
865 Directory to search recursively for F<.pm> files. May not be specified with
870 Array reference of files to examine. May not be specified with C<dir>.
874 String to prepend to the C<file> field of the resulting output. This defaults
875 to F<lib>, which is the common case for most CPAN distributions with their
876 F<.pm> files in F<lib>. This option ensures the META information has the
877 correct relative path even when the C<dir> or C<files> arguments are
878 absolute or have relative paths from a location other than the distribution
883 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
884 is a hashref of the form:
889 file => 'lib/Package/Name.pm'
891 'OtherPackage::Name' => ...
894 =item C<< package_versions_from_directory($dir, \@files?) >>
896 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
897 for those files in C<$dir> - and reads each file for packages and versions,
898 returning a hashref of the form:
903 file => 'Package/Name.pm'
905 'OtherPackage::Name' => ...
908 The C<DB> and C<main> packages are always omitted, as are any "private"
909 packages that have leading underscores in the namespace (e.g.
912 Note that the file path is relative to C<$dir> if that is specified.
913 This B<must not> be used directly for CPAN META C<provides>. See
914 the C<provides> method instead.
916 =item C<< log_info (internal) >>
918 Used internally to perform logging; imported from Log::Contextual if
919 Log::Contextual has already been loaded, otherwise simply calls warn.
923 =head2 Object methods
929 Returns the name of the package represented by this module. If there
930 are more than one packages, it makes a best guess based on the
931 filename. If it's a script (i.e. not a *.pm) the package name is
934 =item C<< version($package) >>
936 Returns the version as defined by the $VERSION variable for the
937 package as returned by the C<name> method if no arguments are
938 given. If given the name of a package it will attempt to return the
939 version of that package if it is specified in the file.
941 =item C<< filename() >>
943 Returns the absolute path to the file.
945 =item C<< packages_inside() >>
947 Returns a list of packages. Note: this is a raw list of packages
948 discovered (or assumed, in the case of C<main>). It is not
949 filtered for C<DB>, C<main> or private packages the way the
950 C<provides> method does.
952 =item C<< pod_inside() >>
954 Returns a list of POD sections.
956 =item C<< contains_pod() >>
958 Returns true if there is any POD in the file.
960 =item C<< pod($section) >>
962 Returns the POD data in the given section.
968 Original code from Module::Build::ModuleInfo by Ken Williams
969 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
971 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
972 assistance from David Golden (xdg) <dagolden@cpan.org>.
974 =head1 COPYRIGHT & LICENSE
976 Original code Copyright (c) 2001-2011 Ken Williams.
977 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
980 This library is free software; you can redistribute it and/or
981 modify it under the same terms as Perl itself.