File Coverage

lib/Test/PAUSE/Permissions.pm

Criterion	Covered	Total	%
statement	15	98	15.3
branch	0	48	0.0
condition	0	40	0.0
subroutine	5	11	45.4
pod	1	1	100.0
total	21	198	10.6

package Test::PAUSE::Permissions;

use strict;
use warnings;
use parent 'Exporter';
use Test::More;
use Parse::LocalDistribution;

our $VERSION = '0.07';

our @EXPORT = (@Test::More::EXPORT, qw/all_permissions_ok/);

sub all_permissions_ok {
  my ($author, $opts) = ref $_[0] ? (undef, @_) : @_;
  $opts ||= {};

  plan skip_all => 'Set RELEASE_TESTING environmental variable to test this.' unless $ENV{RELEASE_TESTING};

  # Get your id from .pause
  $author ||= _get_pause_user();

  plan skip_all => "Can't determine who is going to release." unless $author;

  # Get authority from META
  my $meta_authority ||= _get_authority_in_meta();

  local $Parse::PMFile::ALLOW_DEV_VERSION = 1 if $opts->{dev};

  # Get packages (respecting no_index)
  my $provides = Parse::LocalDistribution->new->parse();

  # Get maintainers from 06perms or MetaCPAN
  my $use_metacpan = $opts->{metacpan} || $ENV{TEST_PAUSE_PERMISSIONS_METACPAN};
  my $maintainers = _get_maintainers($use_metacpan, [keys %$provides]);

  # Iterate
  my $saw_errors;
  my @authorities = grep $_, $author, $meta_authority;
  my %new_packages;
  my %dist_maintainers = map {uc $_ => 1} @authorities;
SKIP:
  for my $package (keys %$provides) {
    my $authority = uc($meta_authority || $author || '');

    my $module_maintainers = $maintainers->{$package};

    if (!$module_maintainers) {
      pass "$package: no one has permissions ($authority should have the first come)";
      $new_packages{$package} = 1;
      next;
    }
    $dist_maintainers{uc $_} = 1 for @$module_maintainers;

    # Author should have permissions, regardless of the authority
    if (grep { uc $_ eq uc $author } @$module_maintainers) {
      pass "$package: $author has a permission";
    }
    else {
      fail "$package: maintained by ".join ', ', @$module_maintainers;
      $saw_errors = 1;
    }

    # $AUTHORITY has no effect in PAUSE.
    # just see if $AUTHORITY matches x_authority for information
    if ($meta_authority) {
      my $file_authority = _get_authority_in_file($package, $provides->{$package});
      if ($file_authority && $file_authority ne $meta_authority) {
        # XXX: should fail?
        diag "$package: \$AUTHORITY ($file_authority) doesn't match x_authority ($meta_authority)";
      }
    }
  }

  # There are several known IDs that won't maintain any package
  delete $dist_maintainers{$_} for qw/ADOPTME HANDOFF NEEDHELP LOCAL/;

  # GH #3: Adding a new module to an established distribution maintained by a large group may cause
  # an annoying permission problem.
  if (
    !$saw_errors  # having errors already means there's someone (ie. you) who can't upload it
    and %new_packages # no problem if no new module is added
    and (keys %new_packages < keys %$provides) # no problem if everything is new
    and (keys %dist_maintainers > @authorities) # no problem if maintainers are few and everyone gets permissions
  ) {
    delete $dist_maintainers{$_} for @authorities;
    my $message = "Some of the maintainers of this distribution (@{[sort keys %dist_maintainers]}) won't have permissions for the following package(s): @{[sort keys %new_packages]}.";
    if ($opts->{strict}) {
      fail $message;
    } else {
      diag "[WARNING] $message\n(This may or may not be a problem, depending on the policy of your team.)";
    }
  }

  done_testing;
}

sub _get_pause_user {
  # Get authority from ~/.pause
  require Config::Identity::PAUSE;
  my %config = Config::Identity::PAUSE->load;
  return $config{user};
}

sub _get_authority_in_meta {
  # Get authority from META
  my $meta = _parse_meta();
  if ($meta && $meta->{x_authority}) {
    my $authority = $meta->{x_authority};
    $authority =~ s/^cpan://i;
    return $authority;
  }
}

sub _parse_meta {
  for my $file (qw/META.json META.yml/) {
    next unless -f $file && -r _;
    my $meta = Parse::CPAN::Meta->load_file($file);
    return $meta if $meta && ref $meta eq ref {};
  }
}

sub _get_authority_in_file {
  my ($package, $package_info) = @_;
  my $file = $package_info->{infile};
  return unless $file && -f $file && -r _;

  open my $fh, '<', $file or return;
  my $in_pod = 0;
  while(<$fh>) {
    last if /__(DATA|END)__/;
    $in_pod = /^=(?!cut?)/ ? 1 : /^=cut/ ? 0 : $in_pod;
    next if $in_pod;

    if (/\$(?:${package}::)?AUTHORITY\s*=.+?(?i:cpan):([A-Za-z0-9]+)/) {
      return $1;
    }
  }
}

sub _get_maintainers {
  my ($use_metacpan, $modules) = @_;
  if ($use_metacpan) {
    eval { require PAUSE::Permissions::MetaCPAN };
    die "To use MetaCPAN permission API, "
      . "you need to install PAUSE::Permissions::MetaCPAN, $@" if $@;
    my $perms = PAUSE::Permissions::MetaCPAN->new->get(modules => $modules);
    my %maintainers;
    for my $module (@$modules) {
      $maintainers{$module} = $perms->{$module}
        ? [ $perms->{$module}{owner}, @{$perms->{$module}{co_maintainers}} ] : undef;
    }
    \%maintainers;
  } else {
    require PAUSE::Permissions;
    my $file = PAUSE::Permissions->new;
    my %maintainers;
    for my $module (@$modules) {
      my $mp = $file->module_permissions($module);
      $maintainers{$module} = $mp ? [$mp->all_maintainers] : undef;
    }
    \%maintainers;
  }
}

1;

__END__