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 # stolen from Module::Build::Version and ::Base - this is perl licensed code,
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.000000';
15 $VERSION = eval $VERSION;
19 use Module::Metadata::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 = Module::Metadata::Version->new($v1)
88 unless UNIVERSAL::isa($v1,'Module::Metadata::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' ||
103 ref $version eq 'Module::Metadata::Version' ) { # version objects
104 $version = $version->is_qv ? $version->normal : $version->stringify;
106 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
107 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
108 $version = "v$version";
116 # separate out some of the conflict resolution logic
118 my $resolve_module_versions = sub {
119 my $packages = shift;
121 my( $file, $version );
123 foreach my $p ( @$packages ) {
124 if ( defined( $p->{version} ) ) {
125 if ( defined( $version ) ) {
126 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
127 $err .= " $p->{file} ($p->{version})\n";
129 # same version declared multiple times, ignore
133 $version = $p->{version};
136 $file ||= $p->{file} if defined( $p->{file} );
140 $err = " $file ($version)\n" . $err;
152 sub package_versions_from_directory {
153 my ( $class, $dir, $files ) = @_;
162 push @files, $_ if -f $_ && /\.pm$/;
168 # First, we enumerate all packages & versions,
169 # separating into primary & alternative candidates
171 foreach my $file (@files) {
172 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
173 my @path = split( /\//, $mapped_filename );
174 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
176 my $pm_info = $class->new_from_file( $file );
178 foreach my $package ( $pm_info->packages_inside ) {
179 next if $package eq 'main'; # main can appear numerous times, ignore
180 next if $package eq 'DB'; # special debugging package, ignore
181 next if grep /^_/, split( /::/, $package ); # private package, ignore
183 my $version = $pm_info->version( $package );
185 if ( $package eq $prime_package ) {
186 if ( exists( $prime{$package} ) ) {
187 # M::B::ModuleInfo will handle this conflict
188 die "Unexpected conflict in '$package'; multiple versions found.\n";
190 $prime{$package}{file} = $mapped_filename;
191 $prime{$package}{version} = $version if defined( $version );
194 push( @{$alt{$package}}, {
195 file => $mapped_filename,
202 # Then we iterate over all the packages found above, identifying conflicts
203 # and selecting the "best" candidate for recording the file & version
205 foreach my $package ( keys( %alt ) ) {
206 my $result = $resolve_module_versions->( $alt{$package} );
208 if ( exists( $prime{$package} ) ) { # primary package selected
210 if ( $result->{err} ) {
211 # Use the selected primary package, but there are conflicting
212 # errors among multiple alternative packages that need to be
215 "Found conflicting versions for package '$package'\n" .
216 " $prime{$package}{file} ($prime{$package}{version})\n" .
220 } elsif ( defined( $result->{version} ) ) {
221 # There is a primary package selected, and exactly one
222 # alternative package
224 if ( exists( $prime{$package}{version} ) &&
225 defined( $prime{$package}{version} ) ) {
226 # Unless the version of the primary package agrees with the
227 # version of the alternative package, report a conflict
228 if ( $compare_versions->(
229 $prime{$package}{version}, '!=', $result->{version}
234 "Found conflicting versions for package '$package'\n" .
235 " $prime{$package}{file} ($prime{$package}{version})\n" .
236 " $result->{file} ($result->{version})\n"
241 # The prime package selected has no version so, we choose to
242 # use any alternative package that does have a version
243 $prime{$package}{file} = $result->{file};
244 $prime{$package}{version} = $result->{version};
248 # no alt package found with a version, but we have a prime
249 # package so we use it whether it has a version or not
252 } else { # No primary package was selected, use the best alternative
254 if ( $result->{err} ) {
256 "Found conflicting versions for package '$package'\n" .
261 # Despite possible conflicting versions, we choose to record
262 # something rather than nothing
263 $prime{$package}{file} = $result->{file};
264 $prime{$package}{version} = $result->{version}
265 if defined( $result->{version} );
269 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
270 # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
271 for (grep defined $_->{version}, values %prime) {
272 $_->{version} = $normalize_version->( $_->{version} );
283 my $filename = shift;
286 my( %valid_props, @valid_props );
287 @valid_props = qw( collect_pod inc );
288 @valid_props{@valid_props} = delete( @props{@valid_props} );
289 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
293 filename => $filename,
304 my $self = bless(\%data, $class);
306 $self->_parse_file();
308 unless($self->{module} and length($self->{module})) {
309 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
312 my @candidates = grep /$f$/, @{$self->{packages}};
313 $self->{module} = shift(@candidates); # punt
316 if(grep /main/, @{$self->{packages}}) {
317 $self->{module} = 'main';
320 $self->{module} = $self->{packages}[0] || '';
325 $self->{version} = $self->{versions}{$self->{module}}
326 if defined( $self->{module} );
332 sub _do_find_module {
334 my $module = shift || die 'find_module_by_name() requires a package name';
335 my $dirs = shift || \@INC;
337 my $file = File::Spec->catfile(split( /::/, $module));
338 foreach my $dir ( @$dirs ) {
339 my $testfile = File::Spec->catfile($dir, $file);
340 return [ File::Spec->rel2abs( $testfile ), $dir ]
341 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
342 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
343 if -e "$testfile.pm";
349 sub find_module_by_name {
350 my $found = shift()->_do_find_module(@_) or return;
355 sub find_module_dir_by_name {
356 my $found = shift()->_do_find_module(@_) or return;
361 # given a line of perl code, attempt to parse it if it looks like a
362 # $VERSION assignment, returning sigil, full name, & package name
363 sub _parse_version_expression {
367 my( $sig, $var, $pkg );
368 if ( $line =~ $VERS_REGEXP ) {
369 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
371 $pkg = ($pkg eq '::') ? 'main' : $pkg;
376 return ( $sig, $var, $pkg );
382 my $filename = $self->{filename};
383 my $fh = IO::File->new( $filename )
384 or die( "Can't open '$filename': $!" );
386 $self->_parse_fh($fh);
390 my ($self, $fh) = @_;
392 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
393 my( @pkgs, %vers, %pod, @pod );
398 while (defined( my $line = <$fh> )) {
402 next if $line =~ /^\s*#/;
404 $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
406 # Would be nice if we could also check $in_string or something too
407 last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
409 if ( $in_pod || $line =~ /^=cut/ ) {
411 if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
413 if ( $self->{collect_pod} && length( $pod_data ) ) {
414 $pod{$pod_sect} = $pod_data;
420 } elsif ( $self->{collect_pod} ) {
421 $pod_data .= "$line\n";
430 # parse $line to see if it's a $VERSION declaration
431 my( $vers_sig, $vers_fullname, $vers_pkg ) =
432 $self->_parse_version_expression( $line );
434 if ( $line =~ $PKG_REGEXP ) {
436 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
437 $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
438 $need_vers = defined $2 ? 0 : 1;
440 # VERSION defined with full package spec, i.e. $Module::VERSION
441 } elsif ( $vers_fullname && $vers_pkg ) {
442 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
443 $need_vers = 0 if $vers_pkg eq $pkg;
445 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
447 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
449 # Warn unless the user is using the "$VERSION = eval
450 # $VERSION" idiom (though there are probably other idioms
451 # that we should watch out for...)
452 warn <<"EOM" unless $line =~ /=\s*eval/;
453 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
454 ignoring subsequent declaration on line $line_num.
458 # first non-comment line in undeclared package main is VERSION
459 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
462 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
464 push( @pkgs, 'main' );
466 # first non-comment line in undeclared package defines package main
467 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
470 push( @pkgs, 'main' );
472 # only keep if this is the first $VERSION seen
473 } elsif ( $vers_fullname && $need_vers ) {
476 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
479 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
483 Package '$pkg' already declared with version '$vers{$pkg}'
484 ignoring new version '$v' on line $line_num.
494 if ( $self->{collect_pod} && length($pod_data) ) {
495 $pod{$pod_sect} = $pod_data;
498 $self->{versions} = \%vers;
499 $self->{packages} = \@pkgs;
500 $self->{pod} = \%pod;
501 $self->{pod_headings} = \@pod;
506 sub _evaluate_version_line {
508 my( $sigil, $var, $line ) = @_;
510 # Some of this code came from the ExtUtils:: hierarchy.
512 # We compile into $vsub because 'use version' would cause
513 # compiletime/runtime issues with local()
515 $pn++; # everybody gets their own package
516 my $eval = qq{BEGIN { q# Hide from _packages_inside()
517 #; package Module::Metadata::_version::p$pn;
518 use Module::Metadata::Version;
530 # Try to get the $VERSION
532 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
533 # installed, so we need to hunt in ./lib for it
534 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
535 local @INC = ('lib',@INC);
538 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
540 (ref($vsub) eq 'CODE') or
541 die "failed to build version sub for $self->{filename}";
542 my $result = eval { $vsub->() };
543 die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
546 # Activestate apparently creates custom versions like '1.23_45_01', which
547 # cause M::B::Version to think it's an invalid alpha. So check for that
549 my $num_dots = () = $result =~ m{\.}g;
550 my $num_unders = () = $result =~ m{_}g;
551 if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) {
555 # Bless it into our own version class
556 eval { $result = Module::Metadata::Version->new($result) };
557 die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
565 ############################################################
568 sub name { $_[0]->{module} }
570 sub filename { $_[0]->{filename} }
571 sub packages_inside { @{$_[0]->{packages}} }
572 sub pod_inside { @{$_[0]->{pod_headings}} }
573 sub contains_pod { $#{$_[0]->{pod_headings}} }
577 my $mod = shift || $self->{module};
579 if ( defined( $mod ) && length( $mod ) &&
580 exists( $self->{versions}{$mod} ) ) {
581 return $self->{versions}{$mod};
590 if ( defined( $sect ) && length( $sect ) &&
591 exists( $self->{pod}{$sect} ) ) {
592 return $self->{pod}{$sect};
602 Module::Metadata - Gather package and POD information from perl module files
608 =item new_from_file($filename, collect_pod => 1)
610 Construct a C<ModuleInfo> object given the path to a file. Takes an optional
611 argument C<collect_pod> which is a boolean that determines whether
612 POD data is collected and stored for reference. POD data is not
613 collected by default. POD headings are always collected.
615 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
617 Construct a C<ModuleInfo> object given a module or package name. In addition
618 to accepting the C<collect_pod> argument as described above, this
619 method accepts a C<inc> argument which is a reference to an array of
620 of directories to search for the module. If none are given, the
625 Returns the name of the package represented by this module. If there
626 are more than one packages, it makes a best guess based on the
627 filename. If it's a script (i.e. not a *.pm) the package name is
630 =item version($package)
632 Returns the version as defined by the $VERSION variable for the
633 package as returned by the C<name> method if no arguments are
634 given. If given the name of a package it will attempt to return the
635 version of that package if it is specified in the file.
639 Returns the absolute path to the file.
641 =item packages_inside()
643 Returns a list of packages.
647 Returns a list of POD sections.
651 Returns true if there is any POD in the file.
655 Returns the POD data in the given section.
657 =item find_module_by_name($module, \@dirs)
659 Returns the path to a module given the module or package name. A list
660 of directories can be passed in as an optional parameter, otherwise
663 Can be called as either an object or a class method.
665 =item find_module_dir_by_name($module, \@dirs)
667 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
668 the module C<$module>. A list of directories can be passed in as an
669 optional parameter, otherwise @INC is searched.
671 Can be called as either an object or a class method.
673 =item package_versions_from_directory($dir, \@files?)
675 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
676 for those files in C<$dir> - and reads each file for packages and versions,
677 returning a hashref of the form:
682 file => 'Package/Name.pm'
684 'OtherPackage::Name' => ...
687 =item log_info (internal)
689 Used internally to perform logging; imported from Log::Contextual if
690 Log::Contextual has already been loaded, otherwise simply calls warn.
696 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
698 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
699 assistance from David Golden (xdg) <dagolden@cpan.org>
703 Copyright (c) 2001-2006 Ken Williams. All rights reserved.
705 This library is free software; you can redistribute it and/or
706 modify it under the same terms as Perl itself.
710 perl(1), L<Module::Build::ModuleInfo>(3)