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.000005';
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 die "Unexpected conflict in '$package'; multiple versions found.\n";
188 $prime{$package}{file} = $mapped_filename;
189 $prime{$package}{version} = $version if defined( $version );
192 push( @{$alt{$package}}, {
193 file => $mapped_filename,
200 # Then we iterate over all the packages found above, identifying conflicts
201 # and selecting the "best" candidate for recording the file & version
203 foreach my $package ( keys( %alt ) ) {
204 my $result = $resolve_module_versions->( $alt{$package} );
206 if ( exists( $prime{$package} ) ) { # primary package selected
208 if ( $result->{err} ) {
209 # Use the selected primary package, but there are conflicting
210 # errors among multiple alternative packages that need to be
213 "Found conflicting versions for package '$package'\n" .
214 " $prime{$package}{file} ($prime{$package}{version})\n" .
218 } elsif ( defined( $result->{version} ) ) {
219 # There is a primary package selected, and exactly one
220 # alternative package
222 if ( exists( $prime{$package}{version} ) &&
223 defined( $prime{$package}{version} ) ) {
224 # Unless the version of the primary package agrees with the
225 # version of the alternative package, report a conflict
226 if ( $compare_versions->(
227 $prime{$package}{version}, '!=', $result->{version}
232 "Found conflicting versions for package '$package'\n" .
233 " $prime{$package}{file} ($prime{$package}{version})\n" .
234 " $result->{file} ($result->{version})\n"
239 # The prime package selected has no version so, we choose to
240 # use any alternative package that does have a version
241 $prime{$package}{file} = $result->{file};
242 $prime{$package}{version} = $result->{version};
246 # no alt package found with a version, but we have a prime
247 # package so we use it whether it has a version or not
250 } else { # No primary package was selected, use the best alternative
252 if ( $result->{err} ) {
254 "Found conflicting versions for package '$package'\n" .
259 # Despite possible conflicting versions, we choose to record
260 # something rather than nothing
261 $prime{$package}{file} = $result->{file};
262 $prime{$package}{version} = $result->{version}
263 if defined( $result->{version} );
267 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
268 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
269 for (grep defined $_->{version}, values %prime) {
270 $_->{version} = $normalize_version->( $_->{version} );
281 my $filename = shift;
284 my( %valid_props, @valid_props );
285 @valid_props = qw( collect_pod inc );
286 @valid_props{@valid_props} = delete( @props{@valid_props} );
287 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
291 filename => $filename,
302 my $self = bless(\%data, $class);
304 $self->_parse_file();
306 unless($self->{module} and length($self->{module})) {
307 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
310 my @candidates = grep /$f$/, @{$self->{packages}};
311 $self->{module} = shift(@candidates); # punt
314 if(grep /main/, @{$self->{packages}}) {
315 $self->{module} = 'main';
318 $self->{module} = $self->{packages}[0] || '';
323 $self->{version} = $self->{versions}{$self->{module}}
324 if defined( $self->{module} );
330 sub _do_find_module {
332 my $module = shift || die 'find_module_by_name() requires a package name';
333 my $dirs = shift || \@INC;
335 my $file = File::Spec->catfile(split( /::/, $module));
336 foreach my $dir ( @$dirs ) {
337 my $testfile = File::Spec->catfile($dir, $file);
338 return [ File::Spec->rel2abs( $testfile ), $dir ]
339 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
340 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
341 if -e "$testfile.pm";
347 sub find_module_by_name {
348 my $found = shift()->_do_find_module(@_) or return;
353 sub find_module_dir_by_name {
354 my $found = shift()->_do_find_module(@_) or return;
359 # given a line of perl code, attempt to parse it if it looks like a
360 # $VERSION assignment, returning sigil, full name, & package name
361 sub _parse_version_expression {
365 my( $sig, $var, $pkg );
366 if ( $line =~ $VERS_REGEXP ) {
367 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
369 $pkg = ($pkg eq '::') ? 'main' : $pkg;
374 return ( $sig, $var, $pkg );
380 my $filename = $self->{filename};
381 my $fh = IO::File->new( $filename )
382 or die( "Can't open '$filename': $!" );
384 $self->_parse_fh($fh);
388 my ($self, $fh) = @_;
390 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
391 my( @pkgs, %vers, %pod, @pod );
396 while (defined( my $line = <$fh> )) {
400 next if $line =~ /^\s*#/;
402 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
404 # Would be nice if we could also check $in_string or something too
405 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
407 if ( $in_pod || $line =~ /^=cut/ ) {
409 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
411 if ( $self->{collect_pod} && length( $pod_data ) ) {
412 $pod{$pod_sect} = $pod_data;
418 } elsif ( $self->{collect_pod} ) {
419 $pod_data .= "$line\n";
428 # parse $line to see if it's a $VERSION declaration
429 my( $vers_sig, $vers_fullname, $vers_pkg ) =
430 $self->_parse_version_expression( $line );
432 if ( $line =~ $PKG_REGEXP ) {
434 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
435 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
436 $need_vers = defined $2 ? 0 : 1;
438 # VERSION defined with full package spec, i.e. $Module::VERSION
439 } elsif ( $vers_fullname && $vers_pkg ) {
440 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
441 $need_vers = 0 if $vers_pkg eq $pkg;
443 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
445 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
447 # Warn unless the user is using the "$VERSION = eval
448 # $VERSION" idiom (though there are probably other idioms
449 # that we should watch out for...)
450 warn <<"EOM" unless $line =~ /=\s*eval/;
451 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
452 ignoring subsequent declaration on line $line_num.
456 # first non-comment line in undeclared package main is VERSION
457 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
460 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
462 push( @pkgs, 'main' );
464 # first non-comment line in undeclared package defines package main
465 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
468 push( @pkgs, 'main' );
470 # only keep if this is the first $VERSION seen
471 } elsif ( $vers_fullname && $need_vers ) {
474 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
477 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
481 Package '$pkg' already declared with version '$vers{$pkg}'
482 ignoring new version '$v' on line $line_num.
492 if ( $self->{collect_pod} && length($pod_data) ) {
493 $pod{$pod_sect} = $pod_data;
496 $self->{versions} = \%vers;
497 $self->{packages} = \@pkgs;
498 $self->{pod} = \%pod;
499 $self->{pod_headings} = \@pod;
504 sub _evaluate_version_line {
506 my( $sigil, $var, $line ) = @_;
508 # Some of this code came from the ExtUtils:: hierarchy.
510 # We compile into $vsub because 'use version' would cause
511 # compiletime/runtime issues with local()
513 $pn++; # everybody gets their own package
514 my $eval = qq{BEGIN { q# Hide from _packages_inside()
515 #; package Module::Metadata::_version::p$pn;
528 # Try to get the $VERSION
530 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
531 # installed, so we need to hunt in ./lib for it
532 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
533 local @INC = ('lib',@INC);
536 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
538 (ref($vsub) eq 'CODE') or
539 die "failed to build version sub for $self->{filename}";
540 my $result = eval { $vsub->() };
541 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
544 # Upgrade it into a version object
545 my $version = eval { _dwim_version($result) };
547 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
548 unless defined $version; # "0" is OK!
554 # Try to DWIM when things fail the lax version test in obvious ways
557 # Best case, it just works
558 sub { return shift },
560 # If we still don't have a version, try stripping any
561 # trailing junk that is prohibited by lax rules
564 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
568 # Activestate apparently creates custom versions like '1.23_45_01', which
569 # cause version.pm to think it's an invalid alpha. So check for that
573 my $num_dots = () = $v =~ m{(\.)}g;
574 my $num_unders = () = $v =~ m{(_)}g;
575 my $leading_v = substr($v,0,1) eq 'v';
576 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
578 $num_unders = () = $v =~ m{(_)}g;
583 # Worst case, try numifying it like we would have before version objects
586 no warnings 'numeric';
593 my ($result) = shift;
595 return $result if ref($result) eq 'version';
597 my ($version, $error);
598 for my $f (@version_prep) {
599 $result = $f->($result);
600 $version = eval { version->new($result) };
601 $error ||= $@ if $@; # capture first failure
602 last if defined $version;
605 die $error unless defined $version;
611 ############################################################
614 sub name { $_[0]->{module} }
616 sub filename { $_[0]->{filename} }
617 sub packages_inside { @{$_[0]->{packages}} }
618 sub pod_inside { @{$_[0]->{pod_headings}} }
619 sub contains_pod { $#{$_[0]->{pod_headings}} }
623 my $mod = shift || $self->{module};
625 if ( defined( $mod ) && length( $mod ) &&
626 exists( $self->{versions}{$mod} ) ) {
627 return $self->{versions}{$mod};
636 if ( defined( $sect ) && length( $sect ) &&
637 exists( $self->{pod}{$sect} ) ) {
638 return $self->{pod}{$sect};
648 Module::Metadata - Gather package and POD information from perl module files
654 =item new_from_file($filename, collect_pod => 1)
656 Construct a C<Module::Metadata> object given the path to a file. Takes an optional
657 argument C<collect_pod> which is a boolean that determines whether
658 POD data is collected and stored for reference. POD data is not
659 collected by default. POD headings are always collected.
661 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
663 Construct a C<Module::Metadata> object given a module or package name. In addition
664 to accepting the C<collect_pod> argument as described above, this
665 method accepts a C<inc> argument which is a reference to an array of
666 of directories to search for the module. If none are given, the
671 Returns the name of the package represented by this module. If there
672 are more than one packages, it makes a best guess based on the
673 filename. If it's a script (i.e. not a *.pm) the package name is
676 =item version($package)
678 Returns the version as defined by the $VERSION variable for the
679 package as returned by the C<name> method if no arguments are
680 given. If given the name of a package it will attempt to return the
681 version of that package if it is specified in the file.
685 Returns the absolute path to the file.
687 =item packages_inside()
689 Returns a list of packages.
693 Returns a list of POD sections.
697 Returns true if there is any POD in the file.
701 Returns the POD data in the given section.
703 =item find_module_by_name($module, \@dirs)
705 Returns the path to a module given the module or package name. A list
706 of directories can be passed in as an optional parameter, otherwise
709 Can be called as either an object or a class method.
711 =item find_module_dir_by_name($module, \@dirs)
713 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
714 the module C<$module>. A list of directories can be passed in as an
715 optional parameter, otherwise @INC is searched.
717 Can be called as either an object or a class method.
719 =item package_versions_from_directory($dir, \@files?)
721 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
722 for those files in C<$dir> - and reads each file for packages and versions,
723 returning a hashref of the form:
728 file => 'Package/Name.pm'
730 'OtherPackage::Name' => ...
733 =item log_info (internal)
735 Used internally to perform logging; imported from Log::Contextual if
736 Log::Contextual has already been loaded, otherwise simply calls warn.
742 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
744 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
745 assistance from David Golden (xdg) <dagolden@cpan.org>
749 Copyright (c) 2001-2011 Ken Williams. All rights reserved.
751 This library is free software; you can redistribute it and/or
752 modify it under the same terms as Perl itself.