File Coverage

blib/lib/Pod/Coverage/TrustMe.pm

Criterion	Covered	Total	%
statement	201	206	97.5
branch	58	82	70.7
condition	29	37	78.3
subroutine	36	36	100.0
pod	10	11	90.9
total	334	372	89.7

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

our $VERSION = '0.001_001';
$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_/,
    qr/\A\(/,           # overload
    (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,
  trust_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 undef;
  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 undef;
  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 !@_;

  my @args =

  $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 _new_pod_parser {
  my $self = shift;

  my $parser = Pod::Coverage::TrustMe::Parser->new;
  if ($self->{nonwhitespace}) {
    $parser->ignore_empty(1);
  }
  return $parser;
}

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

  my %parsed = map {
    my $pack = $_;
    my $pod = $self->_pod_for($pack);

    $pod ? do {
      my $parser = $self->_new_pod_parser;
      $parser->parse_file($pod);

      ($pack => $parser);
    } : ();
  } $self->trusted_packages;

  if ($self->{require_link}) {
    my $package = $self->package;
    my %allowed;
    my %find_links = (
      $package => delete $parsed{$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 {
    my @subs = grep !/::\z/ && defined &{$package.'::'.$_}, keys %{$package.'::'};
    for my $sym ( @subs ) {
      if ($self->{trust_imported}) {
        if (B::svref_2object(\*{$package.'::'.$sym})->GvFLAGS & _GVf_IMPORTED_CV) {
          next;
        }
      }

      next
        if $self->_private_check($sym);

      push @symbols, $sym;
    }
  }

  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 grep { $sym =~ /$_/ } @{ $self->{private} };
}

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

  return scalar grep $sym =~ /$_/,
    @{ $self->{trustme} },
    @{ $self->_trusted_from_pod };
}

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

  my $cv = B::svref_2object($sub);
  my $gv = $cv->GV or return;

  if ($gv->can('object_2svref')) {
    return *{ $gv->object_2svref };
  }
  else {
    no strict 'refs';
    return *{ $gv->STASH->NAME . '::' . $gv->NAME };
  }
}

1;
__END__