File Coverage

blib/lib/Dist/Metadata.pm

Criterion	Covered	Total	%
statement	106	109	97.2
branch	29	34	85.2
condition	22	32	68.7
subroutine	20	20	100.0
pod	10	10	100.0
total	187	205	91.2

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of Dist-Metadata
#
# This software is copyright (c) 2011 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Dist::Metadata;
# git description: v0.925-17-g08a6891

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Information about a perl module distribution
$Dist::Metadata::VERSION = '0.926';
use Carp qw(croak carp);
use CPAN::Meta 2.1 ();
use List::Util qw(first);    # core in perl v5.7.3

# something that is obviously not a real value
sub UNKNOWN () { '- unknown -' } # constant


sub new {
  my $class = shift;
  my $self  = {
    determine_packages => 1,
    @_ == 1 ? %{ $_[0] } : @_
  };

  my @formats = qw( dist file dir struct );
  croak(qq[A dist must be specified (one of ] .
      join(', ', map { "'$_'" } @formats) . ')')
    unless first { $self->{$_} } @formats;

  bless $self, $class;
}


sub dist {
  my ($self) = @_;
  return $self->{dist} ||= do {
    my $dist;
    if( my $struct = $self->{struct} ){
      require Dist::Metadata::Struct;
      $dist = Dist::Metadata::Struct->new(%$struct);
    }
    elsif( my $dir = $self->{dir} ){
      require Dist::Metadata::Dir;
      $dist = Dist::Metadata::Dir->new(dir => $dir);
    }
    elsif ( my $file = $self->{file} ){
      require Dist::Metadata::Archive;
      $dist = Dist::Metadata::Archive->new(file => $file);
    }
    else {
      # new() checks for one and dies without so we shouldn't get here
      croak q[No dist format parameters found!];
    }
    $dist; # return
  };
}


sub default_metadata {
  my ($self) = @_;

  return {
    # required
    abstract       => UNKNOWN,
    author         => [],
    dynamic_config => 0,
    generated_by   => ( ref($self) || $self ) . ' version ' . ( $self->VERSION || 0 ),
    license        => ['unknown'], # this 'unknown' comes from CPAN::Meta::Spec
    'meta-spec'    => {
      version => '2',
      url     => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
    },
    name           => UNKNOWN,

    # strictly speaking, release_status is also required but
    # CPAN::Meta will figure it out based on the version number.  if
    # we were to set it explicitly, then we would first need to
    # examine the version number for '_' or 'TRIAL' or 'RC' etc.

    version        => 0,

    # optional
    no_index => {
      # Ignore the same directories as PAUSE (https://github.com/andk/pause/blob/master/lib/PAUSE/dist.pm#L758):
        # skip "t" - libraries in ./t are test libraries!
        # skip "xt" - libraries in ./xt are author test libraries!
        # skip "inc" - libraries in ./inc are usually install libraries
        # skip "local" - somebody shipped his carton setup!
        # skip 'perl5" - somebody shipped her local::lib!
        # skip 'fatlib' - somebody shipped their fatpack lib!
      directory => [qw( inc t xt local perl5 fatlib )],
    },
    # provides => { package => { file => $file, version => $version } }
  };
}


sub determine_metadata {
  my ($self) = @_;

  my $dist = $self->dist;
  my $meta = $self->default_metadata;

  # get name and version from dist if dist was able to parse them
  foreach my $att (qw(name version)) {
    my $val = $dist->$att;
    # if the dist could determine it that's better than the default
    # but undef won't validate.  value in $self will still override.
    $meta->{$att} = $val
      if defined $val;
  }

  # any passed in values should take priority
  foreach my $field ( keys %$meta ){
    $meta->{$field} = $self->{$field}
      if exists $self->{$field};
  }

  return $meta;
}


sub determine_packages {
  # meta must be passed to avoid infinite loop
  my ( $self, $meta ) = @_;
  # if not passed in, use defaults (we just want the 'no_index' property)
  $meta ||= $self->meta_from_struct( $self->determine_metadata );

  # should_index_file() expects unix paths
  my @files = grep {
    $meta->should_index_file(
      $self->dist->path_classify_file($_)->as_foreign('Unix')->stringify
    );
  }
    $self->dist->perl_files;

  # TODO: should we limit packages to lib/ if it exists?
  # my @lib = grep { m#^lib/# } @files; @files = @lib if @lib;

  return {} if not @files;

  my $packages = $self->dist->determine_packages(@files);


  foreach my $pack ( keys %$packages ) {

    # Remove any packages that should not be indexed
    if ( !$meta->should_index_package($pack) ) {
      delete $packages->{$pack};
      next;
    }

    unless( $self->{include_inner_packages} ){
      # PAUSE only considers packages that match the basename of the
      # containing file.  For example, file Foo.pm may only contain a
      # package that matches /\bFoo$/.  This is what PAUSE calls a
      # "simile".  All other packages in the file will be ignored.

      # capture file basename (without the extension)
      my ($base) = ($packages->{$pack}->{file} =~ m!([^/]+)\.pm(?:\.PL)?$!);
      # remove if file didn't match regexp or package doesn't match basename
      delete $packages->{$pack}
        if !$base || $pack !~ m{\b\Q$base\E$};
    }
  }

  return $packages;
}


sub load_meta {
  my ($self) = @_;

  my $dist  = $self->dist;
  my @files = $dist->list_files;
  my ( $meta, $metafile );
  my $default_meta = $self->determine_metadata;

  # prefer json file (spec v2)
  if ( $metafile = first { m#^META\.json$# } @files ) {
    $meta = CPAN::Meta->load_json_string( $dist->file_content($metafile) );
  }
  # fall back to yaml file (spec v1)
  elsif ( $metafile = first { m#^META\.ya?ml$# } @files ) {
    $meta = CPAN::Meta->load_yaml_string( $dist->file_content($metafile) );
  }
  # no META file found in dist
  else {
    $meta = $self->meta_from_struct( $default_meta );
  }

  {
    # always include (never index) the default no_index dirs
    my $dir = ($meta->{no_index} ||= {})->{directory} ||= [];
    my %seen = map { ($_ => 1) } @$dir;
    unshift @$dir,
      grep { !$seen{$_}++ }
          @{ $default_meta->{no_index}->{directory} };
  }

  # Something has to be indexed, so if META has no (or empty) 'provides'
  # attempt to determine packages unless specifically configured not to
  if ( !keys %{ $meta->provides || {} } && $self->{determine_packages} ) {
    # respect api/encapsulation
    my $struct = $meta->as_struct;
    $struct->{provides} = $self->determine_packages($meta);
    $meta = $self->meta_from_struct($struct);
  }

  return $meta;
}


sub meta {
  my ($self) = @_;
  return $self->{meta} ||= $self->load_meta;
}


sub meta_from_struct {
  my ($self, $struct) = @_;
  return CPAN::Meta->create( $struct, { lazy_validation => 1 } );
}


sub package_versions {
  my ($self) = shift;
  my $provides = @_ ? shift : $self->provides; # || {}
  return {
    map { ($_ => $provides->{$_}{version}) } keys %$provides
  };
}


sub module_info {
  my ($self, $opts) = @_;
  my $provides = $opts->{provides} || $self->provides;
  $provides = { %$provides }; # break reference

  my $checksums = $opts->{checksum} || $opts->{digest} || [];
  $checksums = [ $checksums ]
    unless ref($checksums) eq 'ARRAY';

  my $digest_cache = {};
  foreach my $mod ( keys %$provides ){
    my $data = { %{ $provides->{ $mod } } }; # break reference

    foreach my $checksum ( @$checksums ){
      $data->{ $checksum } =
        $digest_cache->{ $data->{file} }->{ $checksum } ||=
          $self->dist->file_checksum($data->{file}, $checksum);
    }

    # TODO: $opts->{callback}->($self, $mod, $data, sub { $self->dist->file_content($data->{file}) });

    $provides->{ $mod } = $data;
  }

  return $provides;
}


{
  no strict 'refs'; ## no critic (NoStrict)
  foreach my $method ( qw(
    name
    provides
    version
  ) ){
    *$method = sub { $_[0]->meta->$method };
  }
}

1;

__END__