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.000003';
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
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, @_);
77 $props{inc} ||= \@INC;
78 my $filename = $class->find_module_by_name( $module, $props{inc} );
79 return undef unless defined( $filename ) && -f $filename;
80 return $class->_init($module, $filename, %props);
85 my $compare_versions = sub {
86 my ($v1, $op, $v2) = @_;
87 $v1 = version->new($v1)
88 unless UNIVERSAL::isa($v1,'version');
90 my $eval_str = "\$v1 $op \$v2";
91 my $result = eval $eval_str;
92 log_info { "error comparing versions: '$eval_str' $@" } if $@;
97 my $normalize_version = sub {
99 if ( $version =~ /[=<>!,]/ ) { # logic, not just version
100 # take as is without modification
102 elsif ( ref $version eq 'version' ) { # version objects
103 $version = $version->is_qv ? $version->normal : $version->stringify;
105 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
106 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
107 $version = "v$version";
115 # separate out some of the conflict resolution logic
117 my $resolve_module_versions = sub {
118 my $packages = shift;
120 my( $file, $version );
122 foreach my $p ( @$packages ) {
123 if ( defined( $p->{version} ) ) {
124 if ( defined( $version ) ) {
125 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
126 $err .= " $p->{file} ($p->{version})\n";
128 # same version declared multiple times, ignore
132 $version = $p->{version};
135 $file ||= $p->{file} if defined( $p->{file} );
139 $err = " $file ($version)\n" . $err;
151 sub package_versions_from_directory {
152 my ( $class, $dir, $files ) = @_;
161 push @files, $_ if -f $_ && /\.pm$/;
167 # First, we enumerate all packages & versions,
168 # separating into primary & alternative candidates
170 foreach my $file (@files) {
171 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
172 my @path = split( /\//, $mapped_filename );
173 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
175 my $pm_info = $class->new_from_file( $file );
177 foreach my $package ( $pm_info->packages_inside ) {
178 next if $package eq 'main'; # main can appear numerous times, ignore
179 next if $package eq 'DB'; # special debugging package, ignore
180 next if grep /^_/, split( /::/, $package ); # private package, ignore
182 my $version = $pm_info->version( $package );
184 if ( $package eq $prime_package ) {
185 if ( exists( $prime{$package} ) ) {
186 # M::B::ModuleInfo will handle this conflict
187 die "Unexpected conflict in '$package'; multiple versions found.\n";
189 $prime{$package}{file} = $mapped_filename;
190 $prime{$package}{version} = $version if defined( $version );
193 push( @{$alt{$package}}, {
194 file => $mapped_filename,
201 # Then we iterate over all the packages found above, identifying conflicts
202 # and selecting the "best" candidate for recording the file & version
204 foreach my $package ( keys( %alt ) ) {
205 my $result = $resolve_module_versions->( $alt{$package} );
207 if ( exists( $prime{$package} ) ) { # primary package selected
209 if ( $result->{err} ) {
210 # Use the selected primary package, but there are conflicting
211 # errors among multiple alternative packages that need to be
214 "Found conflicting versions for package '$package'\n" .
215 " $prime{$package}{file} ($prime{$package}{version})\n" .
219 } elsif ( defined( $result->{version} ) ) {
220 # There is a primary package selected, and exactly one
221 # alternative package
223 if ( exists( $prime{$package}{version} ) &&
224 defined( $prime{$package}{version} ) ) {
225 # Unless the version of the primary package agrees with the
226 # version of the alternative package, report a conflict
227 if ( $compare_versions->(
228 $prime{$package}{version}, '!=', $result->{version}
233 "Found conflicting versions for package '$package'\n" .
234 " $prime{$package}{file} ($prime{$package}{version})\n" .
235 " $result->{file} ($result->{version})\n"
240 # The prime package selected has no version so, we choose to
241 # use any alternative package that does have a version
242 $prime{$package}{file} = $result->{file};
243 $prime{$package}{version} = $result->{version};
247 # no alt package found with a version, but we have a prime
248 # package so we use it whether it has a version or not
251 } else { # No primary package was selected, use the best alternative
253 if ( $result->{err} ) {
255 "Found conflicting versions for package '$package'\n" .
260 # Despite possible conflicting versions, we choose to record
261 # something rather than nothing
262 $prime{$package}{file} = $result->{file};
263 $prime{$package}{version} = $result->{version}
264 if defined( $result->{version} );
268 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
269 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
270 for (grep defined $_->{version}, values %prime) {
271 $_->{version} = $normalize_version->( $_->{version} );
282 my $filename = shift;
285 my( %valid_props, @valid_props );
286 @valid_props = qw( collect_pod inc );
287 @valid_props{@valid_props} = delete( @props{@valid_props} );
288 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
292 filename => $filename,
303 my $self = bless(\%data, $class);
305 $self->_parse_file();
307 unless($self->{module} and length($self->{module})) {
308 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
311 my @candidates = grep /$f$/, @{$self->{packages}};
312 $self->{module} = shift(@candidates); # punt
315 if(grep /main/, @{$self->{packages}}) {
316 $self->{module} = 'main';
319 $self->{module} = $self->{packages}[0] || '';
324 $self->{version} = $self->{versions}{$self->{module}}
325 if defined( $self->{module} );
331 sub _do_find_module {
333 my $module = shift || die 'find_module_by_name() requires a package name';
334 my $dirs = shift || \@INC;
336 my $file = File::Spec->catfile(split( /::/, $module));
337 foreach my $dir ( @$dirs ) {
338 my $testfile = File::Spec->catfile($dir, $file);
339 return [ File::Spec->rel2abs( $testfile ), $dir ]
340 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
341 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
342 if -e "$testfile.pm";
348 sub find_module_by_name {
349 my $found = shift()->_do_find_module(@_) or return;
354 sub find_module_dir_by_name {
355 my $found = shift()->_do_find_module(@_) or return;
360 # given a line of perl code, attempt to parse it if it looks like a
361 # $VERSION assignment, returning sigil, full name, & package name
362 sub _parse_version_expression {
366 my( $sig, $var, $pkg );
367 if ( $line =~ $VERS_REGEXP ) {
368 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
370 $pkg = ($pkg eq '::') ? 'main' : $pkg;
375 return ( $sig, $var, $pkg );
381 my $filename = $self->{filename};
382 my $fh = IO::File->new( $filename )
383 or die( "Can't open '$filename': $!" );
385 $self->_parse_fh($fh);
389 my ($self, $fh) = @_;
391 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
392 my( @pkgs, %vers, %pod, @pod );
397 while (defined( my $line = <$fh> )) {
401 next if $line =~ /^\s*#/;
403 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
405 # Would be nice if we could also check $in_string or something too
406 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
408 if ( $in_pod || $line =~ /^=cut/ ) {
410 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
412 if ( $self->{collect_pod} && length( $pod_data ) ) {
413 $pod{$pod_sect} = $pod_data;
419 } elsif ( $self->{collect_pod} ) {
420 $pod_data .= "$line\n";
429 # parse $line to see if it's a $VERSION declaration
430 my( $vers_sig, $vers_fullname, $vers_pkg ) =
431 $self->_parse_version_expression( $line );
433 if ( $line =~ $PKG_REGEXP ) {
435 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
436 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
437 $need_vers = defined $2 ? 0 : 1;
439 # VERSION defined with full package spec, i.e. $Module::VERSION
440 } elsif ( $vers_fullname && $vers_pkg ) {
441 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
442 $need_vers = 0 if $vers_pkg eq $pkg;
444 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
446 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
448 # Warn unless the user is using the "$VERSION = eval
449 # $VERSION" idiom (though there are probably other idioms
450 # that we should watch out for...)
451 warn <<"EOM" unless $line =~ /=\s*eval/;
452 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
453 ignoring subsequent declaration on line $line_num.
457 # first non-comment line in undeclared package main is VERSION
458 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
461 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
463 push( @pkgs, 'main' );
465 # first non-comment line in undeclared package defines package main
466 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
469 push( @pkgs, 'main' );
471 # only keep if this is the first $VERSION seen
472 } elsif ( $vers_fullname && $need_vers ) {
475 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
478 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
482 Package '$pkg' already declared with version '$vers{$pkg}'
483 ignoring new version '$v' on line $line_num.
493 if ( $self->{collect_pod} && length($pod_data) ) {
494 $pod{$pod_sect} = $pod_data;
497 $self->{versions} = \%vers;
498 $self->{packages} = \@pkgs;
499 $self->{pod} = \%pod;
500 $self->{pod_headings} = \@pod;
505 sub _evaluate_version_line {
507 my( $sigil, $var, $line ) = @_;
509 # Some of this code came from the ExtUtils:: hierarchy.
511 # We compile into $vsub because 'use version' would cause
512 # compiletime/runtime issues with local()
514 $pn++; # everybody gets their own package
515 my $eval = qq{BEGIN { q# Hide from _packages_inside()
516 #; package Module::Metadata::_version::p$pn;
529 # Try to get the $VERSION
531 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
532 # installed, so we need to hunt in ./lib for it
533 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
534 local @INC = ('lib',@INC);
537 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
539 (ref($vsub) eq 'CODE') or
540 die "failed to build version sub for $self->{filename}";
541 my $result = eval { $vsub->() };
542 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
545 # Upgrade it into a version object
546 my $version = eval { _dwim_version($result) };
548 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
549 unless defined $version; # "0" is OK!
555 # Try to DWIM when things fail the lax version test in obvious ways
558 # Best case, it just works
559 sub { return shift },
561 # If we still don't have a version, try stripping any
562 # trailing junk that is prohibited by lax rules
565 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
569 # Activestate apparently creates custom versions like '1.23_45_01', which
570 # cause version.pm to think it's an invalid alpha. So check for that
574 my $num_dots = () = $v =~ m{(\.)}g;
575 my $num_unders = () = $v =~ m{(_)}g;
576 my $leading_v = substr($v,0,1) eq 'v';
577 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
579 $num_unders = () = $v =~ m{(_)}g;
584 # Worst case, try numifying it like we would have before version objects
587 no warnings 'numeric';
594 my ($result) = shift;
596 return $result if ref($result) eq 'version';
598 my ($version, $error);
599 for my $f (@version_prep) {
600 $result = $f->($result);
601 $version = eval { version->new($result) };
602 $error ||= $@ if $@; # capture first failure
603 last if defined $version;
606 die $error unless defined $version;
612 ############################################################
615 sub name { $_[0]->{module} }
617 sub filename { $_[0]->{filename} }
618 sub packages_inside { @{$_[0]->{packages}} }
619 sub pod_inside { @{$_[0]->{pod_headings}} }
620 sub contains_pod { $#{$_[0]->{pod_headings}} }
624 my $mod = shift || $self->{module};
626 if ( defined( $mod ) && length( $mod ) &&
627 exists( $self->{versions}{$mod} ) ) {
628 return $self->{versions}{$mod};
637 if ( defined( $sect ) && length( $sect ) &&
638 exists( $self->{pod}{$sect} ) ) {
639 return $self->{pod}{$sect};
649 Module::Metadata - Gather package and POD information from perl module files
655 =item new_from_file($filename, collect_pod => 1)
657 Construct a C<ModuleInfo> object given the path to a file. Takes an optional
658 argument C<collect_pod> which is a boolean that determines whether
659 POD data is collected and stored for reference. POD data is not
660 collected by default. POD headings are always collected.
662 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
664 Construct a C<ModuleInfo> object given a module or package name. In addition
665 to accepting the C<collect_pod> argument as described above, this
666 method accepts a C<inc> argument which is a reference to an array of
667 of directories to search for the module. If none are given, the
672 Returns the name of the package represented by this module. If there
673 are more than one packages, it makes a best guess based on the
674 filename. If it's a script (i.e. not a *.pm) the package name is
677 =item version($package)
679 Returns the version as defined by the $VERSION variable for the
680 package as returned by the C<name> method if no arguments are
681 given. If given the name of a package it will attempt to return the
682 version of that package if it is specified in the file.
686 Returns the absolute path to the file.
688 =item packages_inside()
690 Returns a list of packages.
694 Returns a list of POD sections.
698 Returns true if there is any POD in the file.
702 Returns the POD data in the given section.
704 =item find_module_by_name($module, \@dirs)
706 Returns the path to a module given the module or package name. A list
707 of directories can be passed in as an optional parameter, otherwise
710 Can be called as either an object or a class method.
712 =item find_module_dir_by_name($module, \@dirs)
714 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
715 the module C<$module>. A list of directories can be passed in as an
716 optional parameter, otherwise @INC is searched.
718 Can be called as either an object or a class method.
720 =item package_versions_from_directory($dir, \@files?)
722 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
723 for those files in C<$dir> - and reads each file for packages and versions,
724 returning a hashref of the form:
729 file => 'Package/Name.pm'
731 'OtherPackage::Name' => ...
734 =item log_info (internal)
736 Used internally to perform logging; imported from Log::Contextual if
737 Log::Contextual has already been loaded, otherwise simply calls warn.
743 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
745 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
746 assistance from David Golden (xdg) <dagolden@cpan.org>
750 Copyright (c) 2001-2011 Ken Williams. All rights reserved.
752 This library is free software; you can redistribute it and/or
753 modify it under the same terms as Perl itself.