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->_handle_bom($fh, $filename);
445 $self->_parse_fh($fh);
448 # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
449 # If there's one, then skip it and set the :encoding layer appropriately.
451 my ($self, $fh, $filename) = @_;
453 my $pos = $fh->getpos;
454 return unless defined $pos;
457 my $count = $fh->read( $buf, length $buf );
458 return unless defined $count and $count >= 2;
461 if ( $buf eq "\x{FE}\x{FF}" ) {
462 $encoding = 'UTF-16BE';
463 } elsif ( $buf eq "\x{FF}\x{FE}" ) {
464 $encoding = 'UTF-16LE';
465 } elsif ( $buf eq "\x{EF}\x{BB}" ) {
467 $count = $fh->read( $buf, length $buf );
468 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
473 if ( defined $encoding ) {
474 if ( "$]" >= 5.008 ) {
475 # $fh->binmode requires perl 5.10
476 binmode( $fh, ":encoding($encoding)" );
480 or croak( sprintf "Can't reset position to the top of '$filename'" );
487 my ($self, $fh) = @_;
489 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
490 my( @pkgs, %vers, %pod, @pod );
495 while (defined( my $line = <$fh> )) {
501 if ( $line =~ /^=(.{0,3})/ ) {
502 $is_cut = $1 eq 'cut';
506 # Would be nice if we could also check $in_string or something too
507 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
511 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
513 if ( $self->{collect_pod} && length( $pod_data ) ) {
514 $pod{$pod_sect} = $pod_data;
519 } elsif ( $self->{collect_pod} ) {
520 $pod_data .= "$line\n";
524 } elsif ( $is_cut ) {
526 if ( $self->{collect_pod} && length( $pod_data ) ) {
527 $pod{$pod_sect} = $pod_data;
534 # Skip comments in code
535 next if $line =~ /^\s*#/;
537 # parse $line to see if it's a $VERSION declaration
538 my( $vers_sig, $vers_fullname, $vers_pkg ) =
540 ? $self->_parse_version_expression( $line )
543 if ( $line =~ /$PKG_REGEXP/o ) {
545 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
546 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
547 $need_vers = defined $2 ? 0 : 1;
549 # VERSION defined with full package spec, i.e. $Module::VERSION
550 } elsif ( $vers_fullname && $vers_pkg ) {
551 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
552 $need_vers = 0 if $vers_pkg eq $pkg;
554 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
556 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
558 # Warn unless the user is using the "$VERSION = eval
559 # $VERSION" idiom (though there are probably other idioms
560 # that we should watch out for...)
561 warn <<"EOM" unless $line =~ /=\s*eval/;
562 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
563 ignoring subsequent declaration on line $line_num.
567 # first non-comment line in undeclared package main is VERSION
568 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
571 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
573 push( @pkgs, 'main' );
575 # first non-comment line in undeclared package defines package main
576 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
579 push( @pkgs, 'main' );
581 # only keep if this is the first $VERSION seen
582 } elsif ( $vers_fullname && $need_vers ) {
585 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
588 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
592 Package '$pkg' already declared with version '$vers{$pkg}'
593 ignoring new version '$v' on line $line_num.
603 if ( $self->{collect_pod} && length($pod_data) ) {
604 $pod{$pod_sect} = $pod_data;
607 $self->{versions} = \%vers;
608 $self->{packages} = \@pkgs;
609 $self->{pod} = \%pod;
610 $self->{pod_headings} = \@pod;
615 sub _evaluate_version_line {
617 my( $sigil, $var, $line ) = @_;
619 # Some of this code came from the ExtUtils:: hierarchy.
621 # We compile into $vsub because 'use version' would cause
622 # compiletime/runtime issues with local()
624 $pn++; # everybody gets their own package
625 my $eval = qq{BEGIN { q# Hide from _packages_inside()
626 #; package Module::Metadata::_version::p$pn;
639 # Try to get the $VERSION
641 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
642 # installed, so we need to hunt in ./lib for it
643 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
644 local @INC = ('lib',@INC);
647 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
649 (ref($vsub) eq 'CODE') or
650 croak "failed to build version sub for $self->{filename}";
651 my $result = eval { $vsub->() };
652 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
655 # Upgrade it into a version object
656 my $version = eval { _dwim_version($result) };
658 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
659 unless defined $version; # "0" is OK!
665 # Try to DWIM when things fail the lax version test in obvious ways
668 # Best case, it just works
669 sub { return shift },
671 # If we still don't have a version, try stripping any
672 # trailing junk that is prohibited by lax rules
675 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
679 # Activestate apparently creates custom versions like '1.23_45_01', which
680 # cause version.pm to think it's an invalid alpha. So check for that
684 my $num_dots = () = $v =~ m{(\.)}g;
685 my $num_unders = () = $v =~ m{(_)}g;
686 my $leading_v = substr($v,0,1) eq 'v';
687 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
689 $num_unders = () = $v =~ m{(_)}g;
694 # Worst case, try numifying it like we would have before version objects
697 no warnings 'numeric';
704 my ($result) = shift;
706 return $result if ref($result) eq 'version';
708 my ($version, $error);
709 for my $f (@version_prep) {
710 $result = $f->($result);
711 $version = eval { version->new($result) };
712 $error ||= $@ if $@; # capture first failure
713 last if defined $version;
716 croak $error unless defined $version;
722 ############################################################
725 sub name { $_[0]->{module} }
727 sub filename { $_[0]->{filename} }
728 sub packages_inside { @{$_[0]->{packages}} }
729 sub pod_inside { @{$_[0]->{pod_headings}} }
730 sub contains_pod { $#{$_[0]->{pod_headings}} }
734 my $mod = shift || $self->{module};
736 if ( defined( $mod ) && length( $mod ) &&
737 exists( $self->{versions}{$mod} ) ) {
738 return $self->{versions}{$mod};
747 if ( defined( $sect ) && length( $sect ) &&
748 exists( $self->{pod}{$sect} ) ) {
749 return $self->{pod}{$sect};
759 Module::Metadata - Gather package and POD information from perl module files
763 use Module::Metadata;
765 # information about a .pm file
766 my $info = Module::Metadata->new_from_file( $file );
767 my $version = $info->version;
769 # CPAN META 'provides' field for .pm files in a directory
770 my $provides = Module::Metadata->provides(
771 dir => 'lib', version => 2
776 This module provides a standard way to gather metadata about a .pm file
777 without executing unsafe code.
785 =item C<< new_from_file($filename, collect_pod => 1) >>
787 Constructs a C<Module::Metadata> object given the path to a file. Returns
788 undef if the filename does not exist.
790 C<collect_pod> is a optional boolean argument that determines whether POD
791 data is collected and stored for reference. POD data is not collected by
792 default. POD headings are always collected.
794 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
795 it is skipped before processing, and the content of the file is also decoded
796 appropriately starting from perl 5.8.
798 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
800 This works just like C<new_from_file>, except that a handle can be provided
801 as the first argument.
803 Note that there is no validation to confirm that the handle is a handle or
804 something that can act like one. Passing something that isn't a handle will
805 cause a exception when trying to read from it. The C<filename> argument is
806 mandatory or undef will be returned.
808 You are responsible for setting the decoding layers on C<$handle> if
811 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
813 Constructs a C<Module::Metadata> object given a module or package name.
814 Returns undef if the module cannot be found.
816 In addition to accepting the C<collect_pod> argument as described above,
817 this method accepts a C<inc> argument which is a reference to an array of
818 directories to search for the module. If none are given, the default is
821 If the file that contains the module begins by an UTF-8, UTF-16BE or
822 UTF-16LE byte-order mark, then it is skipped before processing, and the
823 content of the file is also decoded appropriately starting from perl 5.8.
825 =item C<< find_module_by_name($module, \@dirs) >>
827 Returns the path to a module given the module or package name. A list
828 of directories can be passed in as an optional parameter, otherwise
831 Can be called as either an object or a class method.
833 =item C<< find_module_dir_by_name($module, \@dirs) >>
835 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
836 the module C<$module>. A list of directories can be passed in as an
837 optional parameter, otherwise @INC is searched.
839 Can be called as either an object or a class method.
841 =item C<< provides( %options ) >>
843 This is a convenience wrapper around C<package_versions_from_directory>
844 to generate a CPAN META C<provides> data structure. It takes key/value
845 pairs. Valid option keys include:
849 =item version B<(required)>
851 Specifies which version of the L<CPAN::Meta::Spec> should be used as
852 the format of the C<provides> output. Currently only '1.4' and '2'
853 are supported (and their format is identical). This may change in
854 the future as the definition of C<provides> changes.
856 The C<version> option is required. If it is omitted or if
857 an unsupported version is given, then C<provides> will throw an error.
861 Directory to search recursively for F<.pm> files. May not be specified with
866 Array reference of files to examine. May not be specified with C<dir>.
870 String to prepend to the C<file> field of the resulting output. This defaults
871 to F<lib>, which is the common case for most CPAN distributions with their
872 F<.pm> files in F<lib>. This option ensures the META information has the
873 correct relative path even when the C<dir> or C<files> arguments are
874 absolute or have relative paths from a location other than the distribution
879 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
880 is a hashref of the form:
885 file => 'lib/Package/Name.pm'
887 'OtherPackage::Name' => ...
890 =item C<< package_versions_from_directory($dir, \@files?) >>
892 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
893 for those files in C<$dir> - and reads each file for packages and versions,
894 returning a hashref of the form:
899 file => 'Package/Name.pm'
901 'OtherPackage::Name' => ...
904 The C<DB> and C<main> packages are always omitted, as are any "private"
905 packages that have leading underscores in the namespace (e.g.
908 Note that the file path is relative to C<$dir> if that is specified.
909 This B<must not> be used directly for CPAN META C<provides>. See
910 the C<provides> method instead.
912 =item C<< log_info (internal) >>
914 Used internally to perform logging; imported from Log::Contextual if
915 Log::Contextual has already been loaded, otherwise simply calls warn.
919 =head2 Object methods
925 Returns the name of the package represented by this module. If there
926 are more than one packages, it makes a best guess based on the
927 filename. If it's a script (i.e. not a *.pm) the package name is
930 =item C<< version($package) >>
932 Returns the version as defined by the $VERSION variable for the
933 package as returned by the C<name> method if no arguments are
934 given. If given the name of a package it will attempt to return the
935 version of that package if it is specified in the file.
937 =item C<< filename() >>
939 Returns the absolute path to the file.
941 =item C<< packages_inside() >>
943 Returns a list of packages. Note: this is a raw list of packages
944 discovered (or assumed, in the case of C<main>). It is not
945 filtered for C<DB>, C<main> or private packages the way the
946 C<provides> method does.
948 =item C<< pod_inside() >>
950 Returns a list of POD sections.
952 =item C<< contains_pod() >>
954 Returns true if there is any POD in the file.
956 =item C<< pod($section) >>
958 Returns the POD data in the given section.
964 Original code from Module::Build::ModuleInfo by Ken Williams
965 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
967 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
968 assistance from David Golden (xdg) <dagolden@cpan.org>.
970 =head1 COPYRIGHT & LICENSE
972 Original code Copyright (c) 2001-2011 Ken Williams.
973 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
976 This library is free software; you can redistribute it and/or
977 modify it under the same terms as Perl itself.