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, @_);
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;
163 sub package_versions_from_directory {
164 my ( $class, $dir, $files ) = @_;
173 push @files, $_ if -f $_ && /\.pm$/;
179 # First, we enumerate all packages & versions,
180 # separating into primary & alternative candidates
182 foreach my $file (@files) {
183 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
184 my @path = split( /\//, $mapped_filename );
185 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
187 my $pm_info = $class->new_from_file( $file );
189 foreach my $package ( $pm_info->packages_inside ) {
190 next if $package eq 'main'; # main can appear numerous times, ignore
191 next if $package eq 'DB'; # special debugging package, ignore
192 next if grep /^_/, split( /::/, $package ); # private package, ignore
194 my $version = $pm_info->version( $package );
196 if ( $package eq $prime_package ) {
197 if ( exists( $prime{$package} ) ) {
198 die "Unexpected conflict in '$package'; multiple versions found.\n";
200 $prime{$package}{file} = $mapped_filename;
201 $prime{$package}{version} = $version if defined( $version );
204 push( @{$alt{$package}}, {
205 file => $mapped_filename,
212 # Then we iterate over all the packages found above, identifying conflicts
213 # and selecting the "best" candidate for recording the file & version
215 foreach my $package ( keys( %alt ) ) {
216 my $result = $resolve_module_versions->( $alt{$package} );
218 if ( exists( $prime{$package} ) ) { # primary package selected
220 if ( $result->{err} ) {
221 # Use the selected primary package, but there are conflicting
222 # errors among multiple alternative packages that need to be
225 "Found conflicting versions for package '$package'\n" .
226 " $prime{$package}{file} ($prime{$package}{version})\n" .
230 } elsif ( defined( $result->{version} ) ) {
231 # There is a primary package selected, and exactly one
232 # alternative package
234 if ( exists( $prime{$package}{version} ) &&
235 defined( $prime{$package}{version} ) ) {
236 # Unless the version of the primary package agrees with the
237 # version of the alternative package, report a conflict
238 if ( $compare_versions->(
239 $prime{$package}{version}, '!=', $result->{version}
244 "Found conflicting versions for package '$package'\n" .
245 " $prime{$package}{file} ($prime{$package}{version})\n" .
246 " $result->{file} ($result->{version})\n"
251 # The prime package selected has no version so, we choose to
252 # use any alternative package that does have a version
253 $prime{$package}{file} = $result->{file};
254 $prime{$package}{version} = $result->{version};
258 # no alt package found with a version, but we have a prime
259 # package so we use it whether it has a version or not
262 } else { # No primary package was selected, use the best alternative
264 if ( $result->{err} ) {
266 "Found conflicting versions for package '$package'\n" .
271 # Despite possible conflicting versions, we choose to record
272 # something rather than nothing
273 $prime{$package}{file} = $result->{file};
274 $prime{$package}{version} = $result->{version}
275 if defined( $result->{version} );
279 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
280 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
281 for (grep defined $_->{version}, values %prime) {
282 $_->{version} = $normalize_version->( $_->{version} );
293 my $filename = shift;
296 my $handle = delete $props{handle};
297 my( %valid_props, @valid_props );
298 @valid_props = qw( collect_pod inc );
299 @valid_props{@valid_props} = delete( @props{@valid_props} );
300 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
304 filename => $filename,
315 my $self = bless(\%data, $class);
318 $self->_parse_fh($handle);
321 $self->_parse_file();
324 unless($self->{module} and length($self->{module})) {
325 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
328 my @candidates = grep /$f$/, @{$self->{packages}};
329 $self->{module} = shift(@candidates); # punt
332 if(grep /main/, @{$self->{packages}}) {
333 $self->{module} = 'main';
336 $self->{module} = $self->{packages}[0] || '';
341 $self->{version} = $self->{versions}{$self->{module}}
342 if defined( $self->{module} );
348 sub _do_find_module {
350 my $module = shift || die 'find_module_by_name() requires a package name';
351 my $dirs = shift || \@INC;
353 my $file = File::Spec->catfile(split( /::/, $module));
354 foreach my $dir ( @$dirs ) {
355 my $testfile = File::Spec->catfile($dir, $file);
356 return [ File::Spec->rel2abs( $testfile ), $dir ]
357 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
358 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
359 if -e "$testfile.pm";
365 sub find_module_by_name {
366 my $found = shift()->_do_find_module(@_) or return;
371 sub find_module_dir_by_name {
372 my $found = shift()->_do_find_module(@_) or return;
377 # given a line of perl code, attempt to parse it if it looks like a
378 # $VERSION assignment, returning sigil, full name, & package name
379 sub _parse_version_expression {
383 my( $sig, $var, $pkg );
384 if ( $line =~ $VERS_REGEXP ) {
385 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
387 $pkg = ($pkg eq '::') ? 'main' : $pkg;
392 return ( $sig, $var, $pkg );
398 my $filename = $self->{filename};
399 my $fh = IO::File->new( $filename )
400 or die( "Can't open '$filename': $!" );
402 $self->_parse_fh($fh);
406 my ($self, $fh) = @_;
408 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
409 my( @pkgs, %vers, %pod, @pod );
414 while (defined( my $line = <$fh> )) {
418 next if $line =~ /^\s*#/;
420 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
422 # Would be nice if we could also check $in_string or something too
423 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
425 if ( $in_pod || $line =~ /^=cut/ ) {
427 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
429 if ( $self->{collect_pod} && length( $pod_data ) ) {
430 $pod{$pod_sect} = $pod_data;
436 } elsif ( $self->{collect_pod} ) {
437 $pod_data .= "$line\n";
446 # parse $line to see if it's a $VERSION declaration
447 my( $vers_sig, $vers_fullname, $vers_pkg ) =
448 $self->_parse_version_expression( $line );
450 if ( $line =~ $PKG_REGEXP ) {
452 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
453 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
454 $need_vers = defined $2 ? 0 : 1;
456 # VERSION defined with full package spec, i.e. $Module::VERSION
457 } elsif ( $vers_fullname && $vers_pkg ) {
458 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
459 $need_vers = 0 if $vers_pkg eq $pkg;
461 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
463 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
465 # Warn unless the user is using the "$VERSION = eval
466 # $VERSION" idiom (though there are probably other idioms
467 # that we should watch out for...)
468 warn <<"EOM" unless $line =~ /=\s*eval/;
469 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
470 ignoring subsequent declaration on line $line_num.
474 # first non-comment line in undeclared package main is VERSION
475 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
478 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
480 push( @pkgs, 'main' );
482 # first non-comment line in undeclared package defines package main
483 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
486 push( @pkgs, 'main' );
488 # only keep if this is the first $VERSION seen
489 } elsif ( $vers_fullname && $need_vers ) {
492 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
495 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
499 Package '$pkg' already declared with version '$vers{$pkg}'
500 ignoring new version '$v' on line $line_num.
510 if ( $self->{collect_pod} && length($pod_data) ) {
511 $pod{$pod_sect} = $pod_data;
514 $self->{versions} = \%vers;
515 $self->{packages} = \@pkgs;
516 $self->{pod} = \%pod;
517 $self->{pod_headings} = \@pod;
522 sub _evaluate_version_line {
524 my( $sigil, $var, $line ) = @_;
526 # Some of this code came from the ExtUtils:: hierarchy.
528 # We compile into $vsub because 'use version' would cause
529 # compiletime/runtime issues with local()
531 $pn++; # everybody gets their own package
532 my $eval = qq{BEGIN { q# Hide from _packages_inside()
533 #; package Module::Metadata::_version::p$pn;
546 # Try to get the $VERSION
548 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
549 # installed, so we need to hunt in ./lib for it
550 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
551 local @INC = ('lib',@INC);
554 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
556 (ref($vsub) eq 'CODE') or
557 die "failed to build version sub for $self->{filename}";
558 my $result = eval { $vsub->() };
559 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
562 # Upgrade it into a version object
563 my $version = eval { _dwim_version($result) };
565 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
566 unless defined $version; # "0" is OK!
572 # Try to DWIM when things fail the lax version test in obvious ways
575 # Best case, it just works
576 sub { return shift },
578 # If we still don't have a version, try stripping any
579 # trailing junk that is prohibited by lax rules
582 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
586 # Activestate apparently creates custom versions like '1.23_45_01', which
587 # cause version.pm to think it's an invalid alpha. So check for that
591 my $num_dots = () = $v =~ m{(\.)}g;
592 my $num_unders = () = $v =~ m{(_)}g;
593 my $leading_v = substr($v,0,1) eq 'v';
594 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
596 $num_unders = () = $v =~ m{(_)}g;
601 # Worst case, try numifying it like we would have before version objects
604 no warnings 'numeric';
611 my ($result) = shift;
613 return $result if ref($result) eq 'version';
615 my ($version, $error);
616 for my $f (@version_prep) {
617 $result = $f->($result);
618 $version = eval { version->new($result) };
619 $error ||= $@ if $@; # capture first failure
620 last if defined $version;
623 die $error unless defined $version;
629 ############################################################
632 sub name { $_[0]->{module} }
634 sub filename { $_[0]->{filename} }
635 sub packages_inside { @{$_[0]->{packages}} }
636 sub pod_inside { @{$_[0]->{pod_headings}} }
637 sub contains_pod { $#{$_[0]->{pod_headings}} }
641 my $mod = shift || $self->{module};
643 if ( defined( $mod ) && length( $mod ) &&
644 exists( $self->{versions}{$mod} ) ) {
645 return $self->{versions}{$mod};
654 if ( defined( $sect ) && length( $sect ) &&
655 exists( $self->{pod}{$sect} ) ) {
656 return $self->{pod}{$sect};
666 Module::Metadata - Gather package and POD information from perl module files
670 use Module::Metadata;
672 # information about a .pm file
673 my $info = Module::Metadata->new_from_file( $file );
674 my $version = $info->version;
676 # information about a directory full of .pm files
678 Module::Metadata->package_versions_from_directory('lib');
682 This module provides a standard way to gather metadata about a .pm file
683 without executing unsafe code.
691 =item C<< new_from_file($filename, collect_pod => 1) >>
693 Construct a C<Module::Metadata> object given the path to a file. Takes an
694 optional argument C<collect_pod> which is a boolean that determines whether POD
695 data is collected and stored for reference. POD data is not collected by
696 default. POD headings are always collected. Returns undef if the filename
699 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
701 This works just like C<new_from_file>, except that a handle can be provided
702 as the first argument. Note that there is no validation to confirm that the
703 handle is a handle or something that can act like one. Passing something that
704 isn't a handle will cause a exception when trying to read from it. The
705 C<filename> argument is mandatory or undef will be returned.
707 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
709 Construct a C<Module::Metadata> object given a module or package name. In addition
710 to accepting the C<collect_pod> argument as described above, this
711 method accepts a C<inc> argument which is a reference to an array of
712 of directories to search for the module. If none are given, the
713 default is @INC. Returns undef if the module cannot be found.
715 =item C<< find_module_by_name($module, \@dirs) >>
717 Returns the path to a module given the module or package name. A list
718 of directories can be passed in as an optional parameter, otherwise
721 Can be called as either an object or a class method.
723 =item C<< find_module_dir_by_name($module, \@dirs) >>
725 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
726 the module C<$module>. A list of directories can be passed in as an
727 optional parameter, otherwise @INC is searched.
729 Can be called as either an object or a class method.
731 =item C<< package_versions_from_directory($dir, \@files?) >>
733 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
734 for those files in C<$dir> - and reads each file for packages and versions,
735 returning a hashref of the form:
740 file => 'Package/Name.pm'
742 'OtherPackage::Name' => ...
745 =item C<< log_info (internal) >>
747 Used internally to perform logging; imported from Log::Contextual if
748 Log::Contextual has already been loaded, otherwise simply calls warn.
752 =head2 Object methods
758 Returns the name of the package represented by this module. If there
759 are more than one packages, it makes a best guess based on the
760 filename. If it's a script (i.e. not a *.pm) the package name is
763 =item C<< version($package) >>
765 Returns the version as defined by the $VERSION variable for the
766 package as returned by the C<name> method if no arguments are
767 given. If given the name of a package it will attempt to return the
768 version of that package if it is specified in the file.
770 =item C<< filename() >>
772 Returns the absolute path to the file.
774 =item C<< packages_inside() >>
776 Returns a list of packages.
778 =item C<< pod_inside() >>
780 Returns a list of POD sections.
782 =item C<< contains_pod() >>
784 Returns true if there is any POD in the file.
786 =item C<< pod($section) >>
788 Returns the POD data in the given section.
794 Original code from Module::Build::ModuleInfo by Ken Williams
795 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
797 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
798 assistance from David Golden (xdg) <dagolden@cpan.org>.
802 Original code Copyright (c) 2001-2011 Ken Williams.
803 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
806 This library is free software; you can redistribute it and/or
807 modify it under the same terms as Perl itself.