File Coverage

blib/lib/Pod/Coverage/TrustMe.pm

Criterion	Covered	Total	%
statement	203	207	98.0
branch	59	82	71.9
condition	35	46	76.0
subroutine	39	39	100.0
pod	10	11	90.9
total	346	385	89.8

package Pod::Coverage::TrustMe;
use strict;
use warnings;

our $VERSION = '0.002000';
$VERSION =~ tr/_//d;

use Pod::Coverage::TrustMe::Parser;
use B ();
use Carp qw(croak);
use constant _GVf_IMPORTED_CV => defined &B::GVf_IMPORTED_CV ? B::GVf_IMPORTED_CV() : 0x80;

use constant DEFAULT_PRIVATE => do {
  my %s;
  [
    qr/\A_/,
    # anything with non-word characters is not standard syntax, so exclude
    # them. this includes overloads, which are internally stored as methods
    # starting with '('.
    qr/\W/,
    (map qr{\A\Q$_\E\z}, grep !$s{$_}++, qw(
      import
      unimport
      VERSION

      can
      isa
      does
      DOES

      AUTOLOAD

      DESTROY
      CLONE
      CLONE_SKIP

      BUILD
      BUILDALL
      BUILDARGS
      FOREIGNBUILDARGS
      DEMOLISH
      DEMOLISHALL

      bootstrap

      TIESCALAR
      FETCH STORE

      TIEARRAY
      FETCH STORE FETCHSIZE STORESIZE EXTEND EXISTS
      DELETE CLEAR PUSH POP SHIFT UNSHIFT SPLICE

      TIEHASH
      FETCH STORE DELETE CLEAR EXISTS FIRSTKEY NEXTKEY SCALAR

      TIEHANDLE
      OPEN BINMODE FILENO SEEK TELL WRITE PRINT PRINTF
      READ READLINE GETC EOF CLOSE

      UNTIE
    )),
    qr/\A
      (?: MODIFY | FETCH )
      _
      (?: REF | SCALAR | ARRAY | HASH | CODE | GLOB | FORMAT | IO )
      _
      ATTRIBUTES
    \z/x,
  ];
};
&Internals::SvREADONLY(+DEFAULT_PRIVATE, 1);

our $PACKAGE_RE = qr{
  (?=[^0-9'])
  (?:
    ::
  |
    \w*
    (?:'[^\W0-9]\w*)*
  )*
}x;
&Internals::SvREADONLY(\$PACKAGE_RE, 1);

my %ALIASES = (
  nonwhitespace => 'require_content',
  trustme       => 'trust_methods',
);

my %DEFAULTS = (
  trust_roles     => 1,
  trust_parents   => 1,
  trust_pod       => 1,
  require_link    => 0,
  export_only     => 0,
  ignore_imported => 1,
  require_content => 0,
  trust_methods   => [],
  trust_packages  => [],
  private         => DEFAULT_PRIVATE,
  pod_from        => undef,
  package         => undef,
);

sub new {
  my ($class, %args) = @_;
  $class = ref $class
    if ref $class;

  for my $alias (sort keys %ALIASES) {
    if (exists $args{$alias}) {
      my $to = $ALIASES{$alias};
      if (exists $args{$to}) {
        croak "$alias is an alias to $to, they can't both be specified!";
      }
      $args{$to} = delete $args{$alias};
    }
  }

  my $new = {
    map +($_ => exists $args{$_} ? $args{$_} : $DEFAULTS{$_}), keys %DEFAULTS,
  };

  if (exists $args{private} || exists $args{also_private}) {
    $new->{private} = [
      map +(ref $_ ? $_ : qr/\A\Q$_\E\z/), (
        @{ $new->{private} },
        exists $args{also_private} ? @{ $args{also_private} } : (),
      )
    ];
  }

  my $package = $new->{package}
    or die "package is a required parameter";

  eval { require(__pack_to_pm($package)); 1 } or do {
    $new->{why_unrated} = "requiring '$package' failed: $@";
    $new->{broken} = 1;
  };

  bless $new, $class;
}

sub package {
  my $self = shift;
  $self->{package};
}

sub symbols {
  my $self = shift;
  return undef
    if $self->{broken};
  $self->{symbols} ||= do {
    my $package = $self->package;

    my %pods    = map +( $_ => 1 ), @{ $self->_get_pods($package) };
    my %symbols = map +(
      $_ => ($pods{$_} || $self->_trust_method_check($_) || 0),
    ), $self->_get_syms($package);

    if (!grep $_, values %symbols) {
      $self->{why_unrated} ||= "no public symbols defined";
    }

    \%symbols;
  };
}

sub coverage {
  my $self = shift;
  my $symbols = $self->symbols
    or return undef;

  my $total = scalar keys %$symbols
    or return undef;
  my $documented = scalar grep $_, values %$symbols;

  return $documented / $total;
}

sub why_unrated {
  my $self = shift;
  return $self->{why_unrated};
}

sub uncovered {
  my $self = shift;
  my $symbols = $self->symbols
    or return ();
  my @uncovered = sort grep !$symbols->{$_}, keys %$symbols;
  return @uncovered;
}
sub naked {
  my $self = shift;
  return $self->uncovered(@_);
}

sub covered {
  my $self = shift;
  my $symbols = $self->symbols
    or return ();
  my @covered = sort grep $symbols->{$_}, keys %$symbols;
  return @covered;
}

sub report {
  my $self = shift;
  my $rating = $self->coverage;

  $rating = 'unrated (' . $self->why_unrated . ')'
    unless defined $rating;

  my $message = sprintf "%s has a Pod coverage rating of %s\n", $self->package, $rating;

  my @uncovered = $self->uncovered;
  if (@uncovered) {
    $message .= "The following are uncovered:\n";
    $message .= "  $_\n"
      for @uncovered;
  }
  return $message;
}

sub print_report {
  my $self = shift;
  print $self->report;
}

sub import {
  my $class = shift;
  return
    if !@_;

  $class->new(@_ == 1 ? (package => $_[0]) : @_)->print_report;
  return;
}


sub _search_packages {
  my $self = shift;
  my @search = @_;
  @search = ('main')
    if !@search;

  s/\A(?:::)?(?:(?:main)?::)+//, s/(?:::)?\z/::/
    for @search;

  my @packages;

  while (@search) {
    my $search = shift @search;
    push @packages, $search;
    my $base = $search eq 'main::' ? '' : $search;

    no strict 'refs';
    my @add =
      map $base.$_,
      sort
      grep /::$/ && $_ ne 'main::',
      keys %$search;

    unshift @search, @add;
  }

  s/::\z//
    for @packages;

  return grep +(
    $_ ne 'main'
    && $_ ne ''
    && $_ ne 'UNIVERSAL'
  ), @packages;
}

sub _get_roles {
  my $self = shift;
  my $package = $self->package;
  my $does
    = $package->can('does') ? 'does'
    : $package->can('DOES') ? 'DOES'
                            : undef;
  if (!$does || $package->can($does) == \&UNIVERSAL::DOES) {
    return;
  }
  return grep $_ ne $package && $package->$does($_), $self->_search_packages;
}

sub _get_parents {
  my $self = shift;
  my $package = $self->package;
  return grep $_ ne $package && $package->isa($_), $self->_search_packages;
}

sub __pack_to_pm {
  my ($package) = @_;
  croak "Invalid package '$package'"
    unless $package =~ /\A$PACKAGE_RE\z/;
  (my $mod = "$package.pm") =~ s{'|::}{/}g;
  return $mod;
}

sub _pod_for {
  my $self = shift;
  my ($package) = @_;
  if ($self->package eq $package && defined $self->{pod_from}) {
    return $self->{pod_from};
  }

  my $mod = __pack_to_pm($package);
  my $full = $INC{$mod} or return;
  (my $maybe_pod = $full) =~ s{\.pm\z}{.pod};
  my $pod
    = -e $maybe_pod ? $maybe_pod
    : -e $full      ? $full
                    : undef
    ;
  if ($self->package eq $package) {
    $self->{pod_from} = $pod;
  }
  return $pod;
}

sub trusted_packages {
  my $self = shift;

  my %seen;
  my @trusted = sort grep !$seen{$_}++,
    $self->package,
    @{ $self->{trust_packages} },
    ($self->{trust_roles} ? $self->_get_roles : ()),
    ($self->{trust_parents} ? $self->_get_parents : ()),
  ;

  return @trusted;
}

sub _pod_parser_class { 'Pod::Coverage::TrustMe::Parser' }
sub _new_pod_parser {
  my $self = shift;

  my $parser = $self->_pod_parser_class->new(@_);
  if ($self->{require_content}) {
    $parser->ignore_empty(1);
  }
  return $parser;
}
sub _pod_parser_for {
  my $self = shift;
  my ($pack) = @_;
  my $pod = $self->_pod_for($pack)
    or return undef;
  my $parser = $self->_new_pod_parser;
  $parser->parse_file($pod);
  return $parser;
}

sub _parsed {
  my $self = shift;
  return $self->{_parsed}
    if $self->{_parsed};

  my %parsed = map {
    my $pack = $_;
    my $parser = $self->_pod_parser_for($pack);
    $parser ? ($pack => $parser) : ();
  } $self->trusted_packages;

  if ($self->{require_link}) {
    my $package = $self->package;
    my %allowed;
    my %find_links = (
      $package => delete $parsed{$package} || $self->_pod_parser_for($package),
    );

    while (%find_links) {
      @allowed{keys %find_links} = values %find_links;
      %find_links =
        map +(exists $parsed{$_} ? ($_ => delete $parsed{$_}) : ()),
        map @{ $_->links },
        values %find_links;
    }

    %parsed = %allowed;
  }

  $self->{_parsed} = \%parsed;
}

sub _symbols_for {
  my $self = shift;
  my ($package) = @_;

  my @symbols;
  no strict 'refs';

  if ($self->{export_only}) {
    @symbols = (
      @{"${package}::EXPORT"},
      @{"${package}::EXPORT_OK"},
    );
  }
  else {
    @symbols =
      grep !(
        $self->{ignore_imported} && $self->_imported_check($_)
        or $self->_private_check($_)
      ),
      grep !/::\z/ && defined &{$package.'::'.$_},
      keys %{$package.'::'};
  }

  return @symbols;
}

sub _get_syms {
  my $self = shift;
  my $syms = $self->{_syms} ||= do {
    # recurse option?
    [ $self->_symbols_for($self->package) ];
  };
  return @$syms;
}

sub _get_pods {
  my $self = shift;

  $self->{_pods} ||= do {
    my $parsed = $self->_parsed;

    my %covered = map +( $_ => 1 ), map @{ $_->covered }, values %$parsed;

    [ sort keys %covered ];
  };
}

sub _trusted_from_pod {
  my $self = shift;

  $self->{_trusted_from_pod} ||= do {
    my $parsed = $self->_parsed;

    [ map @{ $_->trusted }, values %$parsed ];
  };
}

sub _private_check {
  my $self = shift;
  my ($sym) = @_;
  return scalar grep $sym =~ /$_/, @{ $self->{private} };
}

# providing _trustme_check and make overriding it work for compatibility with
# Pod::Coverage
sub _trust_method_check {
  my $self = shift;
  $self->_trustme_check(@_);
}

sub _trustme_check {
  my $self = shift;
  my ($sym) = @_;

  return scalar grep $sym =~ /$_/,
    @{ $self->{trust_methods} },
    ($self->{trust_pod} ? @{ $self->_trusted_from_pod } : ());
}

sub _imported_check {
  my $self = shift;
  my ($sym) = @_;
  my $package = $self->{package};
  no strict 'refs';
  return !!(B::svref_2object(\*{$package.'::'.$sym})->GvFLAGS & _GVf_IMPORTED_CV);
}

1;
__END__