[p5sagit/Module-Metadata.git] / lib / Module / Metadata.pm

# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
package Module::Metadata;

# stolen from Module::Build::Version and ::Base - this is perl licensed code,
# copyright them.

# This module provides routines to gather information about
# perl modules (assuming this may be expanded in the distant
# parrot future to look at other types of modules).

use strict;
use vars qw($VERSION);
$VERSION = '1.000001';
$VERSION = eval $VERSION;

use File::Spec;
use IO::File;
use version 0.87;
BEGIN {
  if ($INC{'Log/Contextual.pm'}) {
    Log::Contextual->import('log_info');
  } else {
    *log_info = sub (&) { warn $_[0]->() };
  }
}
use File::Find qw(find);

my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal

my $PKG_REGEXP  = qr{   # match a package declaration
  ^[\s\{;]*             # intro chars on a line
  package               # the word 'package'
  \s+                   # whitespace
  ([\w:]+)              # a package name
  \s*                   # optional whitespace
  ($V_NUM_REGEXP)?        # optional version number
  \s*                   # optional whitesapce
  ;                     # semicolon line terminator
}x;

my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
  ([\$*])         # sigil - $ or *
  (
    (             # optional leading package name
      (?:::|\')?  # possibly starting like just :: (Ì  la $::VERSION)
      (?:\w+(?:::|\'))*  # Foo::Bar:: ...
    )?
    VERSION
  )\b
}x;

my $VERS_REGEXP = qr{ # match a VERSION definition
  (?:
    \(\s*$VARNAME_REGEXP\s*\) # with parens
  |
    $VARNAME_REGEXP           # without parens
  )
  \s*
  =[^=~]  # = but not ==, nor =~
}x;


sub new_from_file {
  my $class    = shift;
  my $filename = File::Spec->rel2abs( shift );

  return undef unless defined( $filename ) && -f $filename;
  return $class->_init(undef, $filename, @_);
}

sub new_from_module {
  my $class   = shift;
  my $module  = shift;
  my %props   = @_;

  $props{inc} ||= \@INC;
  my $filename = $class->find_module_by_name( $module, $props{inc} );
  return undef unless defined( $filename ) && -f $filename;
  return $class->_init($module, $filename, %props);
}

{
  
  my $compare_versions = sub {
    my ($v1, $op, $v2) = @_;
    $v1 = version->new($v1)
      unless UNIVERSAL::isa($v1,'version');
  
    my $eval_str = "\$v1 $op \$v2";
    my $result   = eval $eval_str;
    log_info { "error comparing versions: '$eval_str' $@" } if $@;
  
    return $result;
  };

  my $normalize_version = sub {
    my ($version) = @_;
    if ( $version =~ /[=<>!,]/ ) { # logic, not just version
      # take as is without modification
    }
    elsif ( ref $version eq 'version' ) { # version objects
      $version = $version->is_qv ? $version->normal : $version->stringify;
    }
    elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
      # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
      $version = "v$version";
    }
    else {
      # leave alone
    }
    return $version;
  };

  # separate out some of the conflict resolution logic

  my $resolve_module_versions = sub {
    my $packages = shift;
  
    my( $file, $version );
    my $err = '';
      foreach my $p ( @$packages ) {
        if ( defined( $p->{version} ) ) {
  	if ( defined( $version ) ) {
   	  if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
  	    $err .= "  $p->{file} ($p->{version})\n";
  	  } else {
  	    # same version declared multiple times, ignore
  	  }
  	} else {
  	  $file    = $p->{file};
  	  $version = $p->{version};
  	}
        }
        $file ||= $p->{file} if defined( $p->{file} );
      }
  
    if ( $err ) {
      $err = "  $file ($version)\n" . $err;
    }
  
    my %result = (
      file    => $file,
      version => $version,
      err     => $err
    );
  
    return \%result;
  };

  sub package_versions_from_directory {
    my ( $class, $dir, $files ) = @_;

    my @files;

    if ( $files ) {
      @files = @$files;
    } else {
      find( {
        wanted => sub {
          push @files, $_ if -f $_ && /\.pm$/;
        },
        no_chdir => 1,
      }, $dir );
    }

    # First, we enumerate all packages & versions,
    # separating into primary & alternative candidates
    my( %prime, %alt );
    foreach my $file (@files) {
      my $mapped_filename = File::Spec->abs2rel( $file, $dir );
      my @path = split( /\//, $mapped_filename );
      (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
  
      my $pm_info = $class->new_from_file( $file );
  
      foreach my $package ( $pm_info->packages_inside ) {
        next if $package eq 'main';  # main can appear numerous times, ignore
        next if $package eq 'DB';    # special debugging package, ignore
        next if grep /^_/, split( /::/, $package ); # private package, ignore
  
        my $version = $pm_info->version( $package );
  
        if ( $package eq $prime_package ) {
          if ( exists( $prime{$package} ) ) {
            # M::B::ModuleInfo will handle this conflict
            die "Unexpected conflict in '$package'; multiple versions found.\n";
          } else {
            $prime{$package}{file} = $mapped_filename;
            $prime{$package}{version} = $version if defined( $version );
          }
        } else {
          push( @{$alt{$package}}, {
                                    file    => $mapped_filename,
                                    version => $version,
                                   } );
        }
      }
    }
  
    # Then we iterate over all the packages found above, identifying conflicts
    # and selecting the "best" candidate for recording the file & version
    # for each package.
    foreach my $package ( keys( %alt ) ) {
      my $result = $resolve_module_versions->( $alt{$package} );
  
      if ( exists( $prime{$package} ) ) { # primary package selected
  
        if ( $result->{err} ) {
  	# Use the selected primary package, but there are conflicting
  	# errors among multiple alternative packages that need to be
  	# reported
          log_info {
  	    "Found conflicting versions for package '$package'\n" .
  	    "  $prime{$package}{file} ($prime{$package}{version})\n" .
  	    $result->{err}
          };
  
        } elsif ( defined( $result->{version} ) ) {
  	# There is a primary package selected, and exactly one
  	# alternative package
  
  	if ( exists( $prime{$package}{version} ) &&
  	     defined( $prime{$package}{version} ) ) {
  	  # Unless the version of the primary package agrees with the
  	  # version of the alternative package, report a conflict
  	  if ( $compare_versions->(
                 $prime{$package}{version}, '!=', $result->{version}
               )
             ) {

            log_info {
              "Found conflicting versions for package '$package'\n" .
  	      "  $prime{$package}{file} ($prime{$package}{version})\n" .
  	      "  $result->{file} ($result->{version})\n"
            };
  	  }
  
  	} else {
  	  # The prime package selected has no version so, we choose to
  	  # use any alternative package that does have a version
  	  $prime{$package}{file}    = $result->{file};
  	  $prime{$package}{version} = $result->{version};
  	}
  
        } else {
  	# no alt package found with a version, but we have a prime
  	# package so we use it whether it has a version or not
        }
  
      } else { # No primary package was selected, use the best alternative
  
        if ( $result->{err} ) {
          log_info {
            "Found conflicting versions for package '$package'\n" .
  	    $result->{err}
          };
        }
  
        # Despite possible conflicting versions, we choose to record
        # something rather than nothing
        $prime{$package}{file}    = $result->{file};
        $prime{$package}{version} = $result->{version}
  	  if defined( $result->{version} );
      }
    }
  
    # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
    # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
    for (grep defined $_->{version}, values %prime) {
      $_->{version} = $normalize_version->( $_->{version} );
    }
  
    return \%prime;
  }
} 
  

sub _init {
  my $class    = shift;
  my $module   = shift;
  my $filename = shift;
  my %props = @_;

  my( %valid_props, @valid_props );
  @valid_props = qw( collect_pod inc );
  @valid_props{@valid_props} = delete( @props{@valid_props} );
  warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );

  my %data = (
    module       => $module,
    filename     => $filename,
    version      => undef,
    packages     => [],
    versions     => {},
    pod          => {},
    pod_headings => [],
    collect_pod  => 0,

    %valid_props,
  );

  my $self = bless(\%data, $class);

  $self->_parse_file();

  unless($self->{module} and length($self->{module})) {
    my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
    if($f =~ /\.pm$/) {
      $f =~ s/\..+$//;
      my @candidates = grep /$f$/, @{$self->{packages}};
      $self->{module} = shift(@candidates); # punt
    }
    else {
      if(grep /main/, @{$self->{packages}}) {
        $self->{module} = 'main';
      }
      else {
        $self->{module} = $self->{packages}[0] || '';
      }
    }
  }

  $self->{version} = $self->{versions}{$self->{module}}
      if defined( $self->{module} );

  return $self;
}

# class method
sub _do_find_module {
  my $class   = shift;
  my $module  = shift || die 'find_module_by_name() requires a package name';
  my $dirs    = shift || \@INC;

  my $file = File::Spec->catfile(split( /::/, $module));
  foreach my $dir ( @$dirs ) {
    my $testfile = File::Spec->catfile($dir, $file);
    return [ File::Spec->rel2abs( $testfile ), $dir ]
	if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
    return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
	if -e "$testfile.pm";
  }
  return;
}

# class method
sub find_module_by_name {
  my $found = shift()->_do_find_module(@_) or return;
  return $found->[0];
}

# class method
sub find_module_dir_by_name {
  my $found = shift()->_do_find_module(@_) or return;
  return $found->[1];
}


# given a line of perl code, attempt to parse it if it looks like a
# $VERSION assignment, returning sigil, full name, & package name
sub _parse_version_expression {
  my $self = shift;
  my $line = shift;

  my( $sig, $var, $pkg );
  if ( $line =~ $VERS_REGEXP ) {
    ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
    if ( $pkg ) {
      $pkg = ($pkg eq '::') ? 'main' : $pkg;
      $pkg =~ s/::$//;
    }
  }

  return ( $sig, $var, $pkg );
}

sub _parse_file {
  my $self = shift;

  my $filename = $self->{filename};
  my $fh = IO::File->new( $filename )
    or die( "Can't open '$filename': $!" );

  $self->_parse_fh($fh);
}

sub _parse_fh {
  my ($self, $fh) = @_;

  my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
  my( @pkgs, %vers, %pod, @pod );
  my $pkg = 'main';
  my $pod_sect = '';
  my $pod_data = '';

  while (defined( my $line = <$fh> )) {
    my $line_num = $.;

    chomp( $line );
    next if $line =~ /^\s*#/;

    $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;

    # Would be nice if we could also check $in_string or something too
    last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;

    if ( $in_pod || $line =~ /^=cut/ ) {

      if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
	push( @pod, $1 );
	if ( $self->{collect_pod} && length( $pod_data ) ) {
          $pod{$pod_sect} = $pod_data;
          $pod_data = '';
        }
	$pod_sect = $1;


      } elsif ( $self->{collect_pod} ) {
	$pod_data .= "$line\n";

      }

    } else {

      $pod_sect = '';
      $pod_data = '';

      # parse $line to see if it's a $VERSION declaration
      my( $vers_sig, $vers_fullname, $vers_pkg ) =
	  $self->_parse_version_expression( $line );

      if ( $line =~ $PKG_REGEXP ) {
        $pkg = $1;
        push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
        $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
        $need_vers = defined $2 ? 0 : 1;

      # VERSION defined with full package spec, i.e. $Module::VERSION
      } elsif ( $vers_fullname && $vers_pkg ) {
	push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
	$need_vers = 0 if $vers_pkg eq $pkg;

	unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
	  $vers{$vers_pkg} =
	    $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
	} else {
	  # Warn unless the user is using the "$VERSION = eval
	  # $VERSION" idiom (though there are probably other idioms
	  # that we should watch out for...)
	  warn <<"EOM" unless $line =~ /=\s*eval/;
Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
ignoring subsequent declaration on line $line_num.
EOM
	}

      # first non-comment line in undeclared package main is VERSION
      } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
	$need_vers = 0;
	my $v =
	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
	$vers{$pkg} = $v;
	push( @pkgs, 'main' );

      # first non-comment line in undeclared package defines package main
      } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
	$need_vers = 1;
	$vers{main} = '';
	push( @pkgs, 'main' );

      # only keep if this is the first $VERSION seen
      } elsif ( $vers_fullname && $need_vers ) {
	$need_vers = 0;
	my $v =
	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );


	unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
	  $vers{$pkg} = $v;
	} else {
	  warn <<"EOM";
Package '$pkg' already declared with version '$vers{$pkg}'
ignoring new version '$v' on line $line_num.
EOM
	}

      }

    }

  }

  if ( $self->{collect_pod} && length($pod_data) ) {
    $pod{$pod_sect} = $pod_data;
  }

  $self->{versions} = \%vers;
  $self->{packages} = \@pkgs;
  $self->{pod} = \%pod;
  $self->{pod_headings} = \@pod;
}

{
my $pn = 0;
sub _evaluate_version_line {
  my $self = shift;
  my( $sigil, $var, $line ) = @_;

  # Some of this code came from the ExtUtils:: hierarchy.

  # We compile into $vsub because 'use version' would cause
  # compiletime/runtime issues with local()
  my $vsub;
  $pn++; # everybody gets their own package
  my $eval = qq{BEGIN { q#  Hide from _packages_inside()
    #; package Module::Metadata::_version::p$pn;
    use version;
    no strict;

    local $sigil$var;
    \$$var=undef;
      \$vsub = sub {
        $line;
        \$$var
      };
  }};

  local $^W;
  # Try to get the $VERSION
  eval $eval;
  # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
  # installed, so we need to hunt in ./lib for it
  if ( $@ =~ /Can't locate/ && -d 'lib' ) {
    local @INC = ('lib',@INC);
    eval $eval;
  }
  warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
    if $@;
  (ref($vsub) eq 'CODE') or
    die "failed to build version sub for $self->{filename}";
  my $result = eval { $vsub->() };
  die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
    if $@;

  # Activestate apparently creates custom versions like '1.23_45_01', which
  # cause M::B::Version to think it's an invalid alpha.  So check for that
  # and strip them
  my $num_dots = () = $result =~ m{\.}g;
  my $num_unders = () = $result =~ m{_}g;
  if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) {
    $result =~ s{_}{}g;
  }

  # Bless it into our own version class
  eval { $result = version->new($result) };
  die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
    if $@;

  return $result;
}
}


############################################################

# accessors
sub name            { $_[0]->{module}           }

sub filename        { $_[0]->{filename}         }
sub packages_inside { @{$_[0]->{packages}}      }
sub pod_inside      { @{$_[0]->{pod_headings}}  }
sub contains_pod    { $#{$_[0]->{pod_headings}} }

sub version {
    my $self = shift;
    my $mod  = shift || $self->{module};
    my $vers;
    if ( defined( $mod ) && length( $mod ) &&
	 exists( $self->{versions}{$mod} ) ) {
	return $self->{versions}{$mod};
    } else {
	return undef;
    }
}

sub pod {
    my $self = shift;
    my $sect = shift;
    if ( defined( $sect ) && length( $sect ) &&
	 exists( $self->{pod}{$sect} ) ) {
	return $self->{pod}{$sect};
    } else {
	return undef;
    }
}

1;

=head1 NAME

Module::Metadata - Gather package and POD information from perl module files

=head1 DESCRIPTION

=over 4

=item new_from_file($filename, collect_pod => 1)

Construct a C<ModuleInfo> object given the path to a file. Takes an optional
argument C<collect_pod> which is a boolean that determines whether
POD data is collected and stored for reference. POD data is not
collected by default. POD headings are always collected.

=item new_from_module($module, collect_pod => 1, inc => \@dirs)

Construct a C<ModuleInfo> object given a module or package name. In addition
to accepting the C<collect_pod> argument as described above, this
method accepts a C<inc> argument which is a reference to an array of
of directories to search for the module. If none are given, the
default is @INC.

=item name()

Returns the name of the package represented by this module. If there
are more than one packages, it makes a best guess based on the
filename. If it's a script (i.e. not a *.pm) the package name is
'main'.

=item version($package)

Returns the version as defined by the $VERSION variable for the
package as returned by the C<name> method if no arguments are
given. If given the name of a package it will attempt to return the
version of that package if it is specified in the file.

=item filename()

Returns the absolute path to the file.

=item packages_inside()

Returns a list of packages.

=item pod_inside()

Returns a list of POD sections.

=item contains_pod()

Returns true if there is any POD in the file.

=item pod($section)

Returns the POD data in the given section.

=item find_module_by_name($module, \@dirs)

Returns the path to a module given the module or package name. A list
of directories can be passed in as an optional parameter, otherwise
@INC is searched.

Can be called as either an object or a class method.

=item find_module_dir_by_name($module, \@dirs)

Returns the entry in C<@dirs> (or C<@INC> by default) that contains
the module C<$module>. A list of directories can be passed in as an
optional parameter, otherwise @INC is searched.

Can be called as either an object or a class method.

=item package_versions_from_directory($dir, \@files?)

Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
for those files in C<$dir> - and reads each file for packages and versions,
returning a hashref of the form:

  {
    'Package::Name' => {
      version => '0.123',
      file => 'Package/Name.pm'
    },
    'OtherPackage::Name' => ...
  }

=item log_info (internal)

Used internally to perform logging; imported from Log::Contextual if
Log::Contextual has already been loaded, otherwise simply calls warn.

=back

=head1 AUTHOR

Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>

Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
assistance from David Golden (xdg) <dagolden@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2001-2006 Ken Williams.  All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

perl(1), L<Module::Build::ModuleInfo>(3)

=cut
Commit	Line	Data
5ac756c6	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;
	4
	5	# stolen from Module::Build::Version and ::Base - this is perl licensed code,
	6	# copyright them.
	7
	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).
	11
	12	use strict;
	13	use vars qw($VERSION);
9d50689d	14	$VERSION = '1.000001';
5ac756c6	15	$VERSION = eval $VERSION;
	16
	17	use File::Spec;
	18	use IO::File;
4850170c	19	use version 0.87;
3db27017	20	BEGIN {
	21	if ($INC{'Log/Contextual.pm'}) {
	22	Log::Contextual->import('log_info');
	23	} else {
e6ddd765	24	*log_info = sub (&) { warn $_[0]->() };
3db27017	25	}
3db27017	26	}
5ac756c6	27	use File::Find qw(find);
	28
	29	my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
	30
	31	my $PKG_REGEXP = qr{ # match a package declaration
	32	^[\s\{;]* # intro chars on a line
	33	package # the word 'package'
	34	\s+ # whitespace
	35	([\w:]+) # a package name
	36	\s* # optional whitespace
	37	($V_NUM_REGEXP)? # optional version number
	38	\s* # optional whitesapce
	39	; # semicolon line terminator
	40	}x;
	41
	42	my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
	43	([\$]) # sigil - $ or
	44	(
	45	( # optional leading package name
	46	(?:::\|\')? # possibly starting like just :: (Ì la $::VERSION)
	47	(?:\w+(?:::\|\'))* # Foo::Bar:: ...
	48	)?
	49	VERSION
	50	)\b
	51	}x;
	52
	53	my $VERS_REGEXP = qr{ # match a VERSION definition
	54	(?:
	55	\(\s$VARNAME_REGEXP\s\) # with parens
	56	\|
	57	$VARNAME_REGEXP # without parens
	58	)
	59	\s*
	60	=[^=~] # = but not ==, nor =~
	61	}x;
	62
	63
	64	sub new_from_file {
	65	my $class = shift;
	66	my $filename = File::Spec->rel2abs( shift );
	67
	68	return undef unless defined( $filename ) && -f $filename;
	69	return $class->_init(undef, $filename, @_);
	70	}
	71
	72	sub new_from_module {
	73	my $class = shift;
	74	my $module = shift;
	75	my %props = @_;
	76
	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);
	81	}
	82
	83	{
	84
	85	my $compare_versions = sub {
	86	my ($v1, $op, $v2) = @_;
4850170c	87	$v1 = version->new($v1)
4850170c	88	unless UNIVERSAL::isa($v1,'version');
5ac756c6	89
	90	my $eval_str = "\$v1 $op \$v2";
	91	my $result = eval $eval_str;
	92	log_info { "error comparing versions: '$eval_str' $@" } if $@;
	93
	94	return $result;
	95	};
	96
	97	my $normalize_version = sub {
	98	my ($version) = @_;
	99	if ( $version =~ /[=<>!,]/ ) { # logic, not just version
	100	# take as is without modification
	101	}
4850170c	102	elsif ( ref $version eq 'version' ) { # version objects
5ac756c6	103	$version = $version->is_qv ? $version->normal : $version->stringify;
	104	}
	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";
	108	}
	109	else {
	110	# leave alone
	111	}
	112	return $version;
	113	};
	114
	115	# separate out some of the conflict resolution logic
	116
	117	my $resolve_module_versions = sub {
	118	my $packages = shift;
	119
	120	my( $file, $version );
	121	my $err = '';
	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";
	127	} else {
	128	# same version declared multiple times, ignore
	129	}
	130	} else {
	131	$file = $p->{file};
	132	$version = $p->{version};
	133	}
	134	}
	135	$file \|\|= $p->{file} if defined( $p->{file} );
	136	}
	137
	138	if ( $err ) {
	139	$err = " $file ($version)\n" . $err;
	140	}
	141
	142	my %result = (
	143	file => $file,
	144	version => $version,
	145	err => $err
	146	);
	147
	148	return \%result;
	149	};
	150
	151	sub package_versions_from_directory {
	152	my ( $class, $dir, $files ) = @_;
	153
	154	my @files;
	155
	156	if ( $files ) {
	157	@files = @$files;
	158	} else {
	159	find( {
	160	wanted => sub {
	161	push @files, $_ if -f $_ && /\.pm$/;
	162	},
	163	no_chdir => 1,
	164	}, $dir );
	165	}
	166
167	# First, we enumerate all packages & versions,
168	# separating into primary & alternative candidates
169	my( %prime, %alt );
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$//;
174
175	my $pm_info = $class->new_from_file( $file );
176
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
181
182	my $version = $pm_info->version( $package );
183
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";
188	} else {
189	$prime{$package}{file} = $mapped_filename;
190	$prime{$package}{version} = $version if defined( $version );
191	}
192	} else {
193	push( @{$alt{$package}}, {
194	file => $mapped_filename,
195	version => $version,
196	} );
197	}
198	}
199	}
200
201	# Then we iterate over all the packages found above, identifying conflicts
202	# and selecting the "best" candidate for recording the file & version
203	# for each package.
204	foreach my $package ( keys( %alt ) ) {
205	my $result = $resolve_module_versions->( $alt{$package} );
206
207	if ( exists( $prime{$package} ) ) { # primary package selected
208
209	if ( $result->{err} ) {
210	# Use the selected primary package, but there are conflicting
211	# errors among multiple alternative packages that need to be
212	# reported
213	log_info {
214	"Found conflicting versions for package '$package'\n" .
215	" $prime{$package}{file} ($prime{$package}{version})\n" .
216	$result->{err}
217	};
218
219	} elsif ( defined( $result->{version} ) ) {
220	# There is a primary package selected, and exactly one
221	# alternative package
222
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}
229	)
230	) {
231
232	log_info {
233	"Found conflicting versions for package '$package'\n" .
234	" $prime{$package}{file} ($prime{$package}{version})\n" .
235	" $result->{file} ($result->{version})\n"
236	};
237	}
238
239	} else {
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};
244	}
245
246	} else {
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
249	}
250
251	} else { # No primary package was selected, use the best alternative
252
253	if ( $result->{err} ) {
254	log_info {
255	"Found conflicting versions for package '$package'\n" .
256	$result->{err}
257	};
258	}
259
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} );
265	}
266	}
267
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} );
272	}
273
274	return \%prime;
275	}
276	}
277
278
279	sub _init {
280	my $class = shift;
281	my $module = shift;
282	my $filename = shift;
283	my %props = @_;
284
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 );
289
290	my %data = (
291	module => $module,
292	filename => $filename,
293	version => undef,
294	packages => [],
295	versions => {},
296	pod => {},
297	pod_headings => [],
298	collect_pod => 0,
299
300	%valid_props,
301	);
302
303	my $self = bless(\%data, $class);
304
305	$self->_parse_file();
306
307	unless($self->{module} and length($self->{module})) {
308	my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
309	if($f =~ /\.pm$/) {
310	$f =~ s/\..+$//;
311	my @candidates = grep /$f$/, @{$self->{packages}};
312	$self->{module} = shift(@candidates); # punt
313	}
314	else {
315	if(grep /main/, @{$self->{packages}}) {
316	$self->{module} = 'main';
317	}
318	else {
319	$self->{module} = $self->{packages}[0] \|\| '';
320	}
321	}
322	}
323
324	$self->{version} = $self->{versions}{$self->{module}}
325	if defined( $self->{module} );
326
327	return $self;
328	}
329
330	# class method
331	sub _do_find_module {
332	my $class = shift;
333	my $module = shift \|\| die 'find_module_by_name() requires a package name';
334	my $dirs = shift \|\| \@INC;
335
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";
343	}
344	return;
345	}
346
347	# class method
348	sub find_module_by_name {
349	my $found = shift()->_do_find_module(@_) or return;
350	return $found->[0];
351	}
352
353	# class method
354	sub find_module_dir_by_name {
355	my $found = shift()->_do_find_module(@_) or return;
356	return $found->[1];
357	}
358
359
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 {
363	my $self = shift;
364	my $line = shift;
365
366	my( $sig, $var, $pkg );
367	if ( $line =~ $VERS_REGEXP ) {
368	( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
369	if ( $pkg ) {
370	$pkg = ($pkg eq '::') ? 'main' : $pkg;
371	$pkg =~ s/::$//;
372	}
373	}
374
375	return ( $sig, $var, $pkg );
376	}
377
378	sub _parse_file {
379	my $self = shift;
380
381	my $filename = $self->{filename};
382	my $fh = IO::File->new( $filename )
383	or die( "Can't open '$filename': $!" );
384
385	$self->_parse_fh($fh);
386	}
387
388	sub _parse_fh {
389	my ($self, $fh) = @_;
390
391	my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
392	my( @pkgs, %vers, %pod, @pod );
393	my $pkg = 'main';
394	my $pod_sect = '';
395	my $pod_data = '';
396
397	while (defined( my $line = <$fh> )) {
398	my $line_num = $.;
399
400	chomp( $line );
401	next if $line =~ /^\s*#/;
402
403	$in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
404
405	# Would be nice if we could also check $in_string or something too
406	last if !$in_pod && $line =~ /^__(?:DATA\|END)__$/;
407
408	if ( $in_pod \|\| $line =~ /^=cut/ ) {
409
410	if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
411	push( @pod, $1 );
412	if ( $self->{collect_pod} && length( $pod_data ) ) {
413	$pod{$pod_sect} = $pod_data;
414	$pod_data = '';
415	}
416	$pod_sect = $1;
417
418
419	} elsif ( $self->{collect_pod} ) {
420	$pod_data .= "$line\n";
421
422	}
423
424	} else {
425
426	$pod_sect = '';
427	$pod_data = '';
428
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 );
432
433	if ( $line =~ $PKG_REGEXP ) {
434	$pkg = $1;
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;
438
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;
443
444	unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
445	$vers{$vers_pkg} =
446	$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
447	} else {
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.
454	EOM
455	}
456
457	# first non-comment line in undeclared package main is VERSION
458	} elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
459	$need_vers = 0;
460	my $v =
461	$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
462	$vers{$pkg} = $v;
463	push( @pkgs, 'main' );
464
465	# first non-comment line in undeclared package defines package main
466	} elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
467	$need_vers = 1;
468	$vers{main} = '';
469	push( @pkgs, 'main' );
470
471	# only keep if this is the first $VERSION seen
472	} elsif ( $vers_fullname && $need_vers ) {
473	$need_vers = 0;
474	my $v =
475	$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
476
477
478	unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
479	$vers{$pkg} = $v;
480	} else {
481	warn <<"EOM";
482	Package '$pkg' already declared with version '$vers{$pkg}'
483	ignoring new version '$v' on line $line_num.
484	EOM
485	}
486
487	}
488
489	}
490
491	}
492
493	if ( $self->{collect_pod} && length($pod_data) ) {
494	$pod{$pod_sect} = $pod_data;
495	}
496
497	$self->{versions} = \%vers;
498	$self->{packages} = \@pkgs;
499	$self->{pod} = \%pod;
500	$self->{pod_headings} = \@pod;
501	}
502
503	{
504	my $pn = 0;
505	sub _evaluate_version_line {
506	my $self = shift;
507	my( $sigil, $var, $line ) = @_;
508
509	# Some of this code came from the ExtUtils:: hierarchy.
510
511	# We compile into $vsub because 'use version' would cause
512	# compiletime/runtime issues with local()
513	my $vsub;
514	$pn++; # everybody gets their own package
515	my $eval = qq{BEGIN { q# Hide from _packages_inside()
516	#; package Module::Metadata::_version::p$pn;
4850170c	517	use version;
5ac756c6	518	no strict;
	519
	520	local $sigil$var;
	521	\$$var=undef;
	522	\$vsub = sub {
	523	$line;
	524	\$$var
	525	};
	526	}};
	527
	528	local $^W;
	529	# Try to get the $VERSION
	530	eval $eval;
	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);
	535	eval $eval;
	536	}
	537	warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
	538	if $@;
	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"
	543	if $@;
	544
	545	# Activestate apparently creates custom versions like '1.23_45_01', which
	546	# cause M::B::Version to think it's an invalid alpha. So check for that
	547	# and strip them
	548	my $num_dots = () = $result =~ m{\.}g;
	549	my $num_unders = () = $result =~ m{_}g;
	550	if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) {
	551	$result =~ s{_}{}g;
	552	}
	553
	554	# Bless it into our own version class
4850170c	555	eval { $result = version->new($result) };
5ac756c6	556	die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
	557	if $@;
	558
	559	return $result;
	560	}
	561	}
	562
	563
	564	############################################################
	565
	566	# accessors
	567	sub name { $_[0]->{module} }
	568
	569	sub filename { $_[0]->{filename} }
	570	sub packages_inside { @{$_[0]->{packages}} }
	571	sub pod_inside { @{$_[0]->{pod_headings}} }
	572	sub contains_pod { $#{$_[0]->{pod_headings}} }
	573
	574	sub version {
	575	my $self = shift;
	576	my $mod = shift \|\| $self->{module};
	577	my $vers;
	578	if ( defined( $mod ) && length( $mod ) &&
	579	exists( $self->{versions}{$mod} ) ) {
	580	return $self->{versions}{$mod};
	581	} else {
	582	return undef;
	583	}
	584	}
	585
	586	sub pod {
	587	my $self = shift;
	588	my $sect = shift;
	589	if ( defined( $sect ) && length( $sect ) &&
	590	exists( $self->{pod}{$sect} ) ) {
	591	return $self->{pod}{$sect};
	592	} else {
	593	return undef;
	594	}
	595	}
	596
	597	1;
	598
5ac756c6	599	=head1 NAME
5ac756c6	600
2c11e51d	601	Module::Metadata - Gather package and POD information from perl module files
5ac756c6	602
	603	=head1 DESCRIPTION
	604
	605	=over 4
	606
	607	=item new_from_file($filename, collect_pod => 1)
	608
	609	Construct a C<ModuleInfo> object given the path to a file. Takes an optional
	610	argument C<collect_pod> which is a boolean that determines whether
	611	POD data is collected and stored for reference. POD data is not
	612	collected by default. POD headings are always collected.
	613
	614	=item new_from_module($module, collect_pod => 1, inc => \@dirs)
	615
	616	Construct a C<ModuleInfo> object given a module or package name. In addition
	617	to accepting the C<collect_pod> argument as described above, this
	618	method accepts a C<inc> argument which is a reference to an array of
	619	of directories to search for the module. If none are given, the
	620	default is @INC.
	621
	622	=item name()
	623
	624	Returns the name of the package represented by this module. If there
	625	are more than one packages, it makes a best guess based on the
	626	filename. If it's a script (i.e. not a *.pm) the package name is
	627	'main'.
	628
	629	=item version($package)
	630
	631	Returns the version as defined by the $VERSION variable for the
	632	package as returned by the C<name> method if no arguments are
	633	given. If given the name of a package it will attempt to return the
	634	version of that package if it is specified in the file.
	635
	636	=item filename()
	637
	638	Returns the absolute path to the file.
	639
	640	=item packages_inside()
	641
	642	Returns a list of packages.
	643
	644	=item pod_inside()
	645
	646	Returns a list of POD sections.
	647
	648	=item contains_pod()
	649
	650	Returns true if there is any POD in the file.
	651
	652	=item pod($section)
	653
	654	Returns the POD data in the given section.
	655
	656	=item find_module_by_name($module, \@dirs)
	657
	658	Returns the path to a module given the module or package name. A list
	659	of directories can be passed in as an optional parameter, otherwise
	660	@INC is searched.
	661
	662	Can be called as either an object or a class method.
	663
	664	=item find_module_dir_by_name($module, \@dirs)
	665
666	Returns the entry in C<@dirs> (or C<@INC> by default) that contains
667	the module C<$module>. A list of directories can be passed in as an
668	optional parameter, otherwise @INC is searched.
669
670	Can be called as either an object or a class method.
671
2c11e51d	672	=item package_versions_from_directory($dir, \@files?)
	673
	674	Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
	675	for those files in C<$dir> - and reads each file for packages and versions,
	676	returning a hashref of the form:
5ac756c6	677
2c11e51d	678	{
	679	'Package::Name' => {
	680	version => '0.123',
	681	file => 'Package/Name.pm'
	682	},
	683	'OtherPackage::Name' => ...
	684	}
	685
	686	=item log_info (internal)
	687
	688	Used internally to perform logging; imported from Log::Contextual if
	689	Log::Contextual has already been loaded, otherwise simply calls warn.
	690
	691	=back
5ac756c6	692
	693	=head1 AUTHOR
	694
	695	Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
	696
2c11e51d	697	Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
2c11e51d	698	assistance from David Golden (xdg) <dagolden@cpan.org>
5ac756c6	699
	700	=head1 COPYRIGHT
	701
	702	Copyright (c) 2001-2006 Ken Williams. All rights reserved.
	703
	704	This library is free software; you can redistribute it and/or
	705	modify it under the same terms as Perl itself.
	706
5ac756c6	707	=head1 SEE ALSO
5ac756c6	708
2c11e51d	709	perl(1), L<Module::Build::ModuleInfo>(3)
5ac756c6	710
	711	=cut
	712