File Coverage

blib/lib/Pod/Coverage/TrustMe.pm

Criterion	Covered	Total	%
statement	195	198	98.4
branch	52	74	70.2
condition	33	43	76.7
subroutine	38	38	100.0
pod	10	11	90.9
total	328	364	90.1

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

our $VERSION = '0.001002';
$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

      can
      isa
      does
      DOES

      AUTOLOAD

      DESTROY
      CLONE
      CLONE_SKIP

      BUILD
      BUILDALL
      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 %DEFAULTS = (
  trust_roles     => 1,
  trust_parents   => 1,
  trust_pod       => 1,
  require_link    => 0,
  export_only     => 0,
  ignore_imported => 1,
  nonwhitespace   => 0,
  trustme         => [],
  private         => DEFAULT_PRIVATE,
  pod_from        => undef,
  package         => undef,
);

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

  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->_trustme_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'
                            : 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 %to_parse = (
    $self->package => 1,
  );
  @to_parse{$self->_get_roles} = ()
    if $self->{trust_roles};
  @to_parse{$self->_get_parents} = ()
    if $self->{trust_parents};

  my @trusted = sort keys %to_parse;
  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->{nonwhitespace}) {
    $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} };
}

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

  return scalar grep $sym =~ /$_/,
    @{ $self->{trustme} },
    @{ $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__