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
672 =item new_from_file($filename, collect_pod => 1)
674 Construct a C<Module::Metadata> object given the path to a file. Takes an optional
675 argument C<collect_pod> which is a boolean that determines whether
676 POD data is collected and stored for reference. POD data is not
677 collected by default. POD headings are always collected.
679 =item new_from_handle($handle, $filename, collect_pod => 1)
681 This works just like C<new_from_file>, except that a handle can be provided
682 as the first argument. Note that there is no validation to confirm that the
683 handle is a handle or something that can act like one. Passing something that
684 isn't a handle will cause a exception when trying to read from it. The
685 C<filename> argument is mandatory or undef will be returned.
687 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
689 Construct a C<Module::Metadata> object given a module or package name. In addition
690 to accepting the C<collect_pod> argument as described above, this
691 method accepts a C<inc> argument which is a reference to an array of
692 of directories to search for the module. If none are given, the
698 Returns the name of the package represented by this module. If there
699 are more than one packages, it makes a best guess based on the
700 filename. If it's a script (i.e. not a *.pm) the package name is
703 =item version($package)
705 Returns the version as defined by the $VERSION variable for the
706 package as returned by the C<name> method if no arguments are
707 given. If given the name of a package it will attempt to return the
708 version of that package if it is specified in the file.
712 Returns the absolute path to the file.
714 =item packages_inside()
716 Returns a list of packages.
720 Returns a list of POD sections.
724 Returns true if there is any POD in the file.
728 Returns the POD data in the given section.
730 =item find_module_by_name($module, \@dirs)
732 Returns the path to a module given the module or package name. A list
733 of directories can be passed in as an optional parameter, otherwise
736 Can be called as either an object or a class method.
738 =item find_module_dir_by_name($module, \@dirs)
740 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
741 the module C<$module>. A list of directories can be passed in as an
742 optional parameter, otherwise @INC is searched.
744 Can be called as either an object or a class method.
746 =item package_versions_from_directory($dir, \@files?)
748 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
749 for those files in C<$dir> - and reads each file for packages and versions,
750 returning a hashref of the form:
755 file => 'Package/Name.pm'
757 'OtherPackage::Name' => ...
760 =item log_info (internal)
762 Used internally to perform logging; imported from Log::Contextual if
763 Log::Contextual has already been loaded, otherwise simply calls warn.
769 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
771 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
772 assistance from David Golden (xdg) <dagolden@cpan.org>
776 Copyright (c) 2001-2011 Ken Williams. All rights reserved.
778 This library is free software; you can redistribute it and/or
779 modify it under the same terms as Perl itself.