File Coverage

blib/lib/Test/Pod/Coverage/TrustMe.pm

Criterion	Covered	Total	%
statement	102	109	93.5
branch	30	42	71.4
condition	17	35	48.5
subroutine	13	13	100.0
pod	3	3	100.0
total	165	202	81.6

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

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

use File::Spec ();
use Cwd ();
use Test::Builder ();

use Exporter ();
*import = \&Exporter::import;

our @EXPORT = qw(
  all_modules
  pod_coverage_ok
  all_pod_coverage_ok
);

sub _blib {
  my $dir = File::Spec->curdir;
  my $try = 5;
  while ($try--) {
    my $blib = File::Spec->catdir($dir, 'blib');
    if (
      -d $blib
      && -d File::Spec->catdir($blib, 'arch')
      && -d File::Spec->catdir($blib, 'lib')
    ) {
      return $blib;
    }

    $dir = File::Spec->catdir($dir, File::Spec->updir);
  }
  return undef;
}

sub _lib {
  my $dir = File::Spec->curdir;
  my $try = 5;
  while ($try--) {
    my $lib = File::Spec->catdir($dir, 'lib');
    if (-d $lib) {
      my @parts = File::Spec->splitdir(Cwd::realpath($lib));
      if (
        @parts >= 2
        && $parts[-1] eq 'lib'
        && ($parts[-2] eq 't' || $parts[-2] eq 'xt')
      ) {
        next;
      }

      return $lib;
    }

    $dir = File::Spec->catdir($dir, File::Spec->updir);
  }
  return undef;
}

sub _base_dirs {
  my %find;
  if (my $lib = _lib()) {
    $find{Cwd::realpath($lib)}++;
  }
  if (my $blib = _blib()) {
    $find{Cwd::realpath(File::Spec->catdir($blib, 'arch'))}++;
    $find{Cwd::realpath(File::Spec->catdir($blib, 'lib'))}++;
  }

  my @dirs = grep $find{Cwd::realpath($_)}, @INC;
  return @dirs;
}

sub all_modules {
  my @dirs = @_;
  @dirs = _base_dirs
    if !@dirs;

  my %searched;
  my @modules;
  my %modules;

  my @search = map [$_], @dirs;
  while (my $search = shift @search) {
    my ($dir, @pre) = @$search;
    next
      if $searched{Cwd::realpath($dir)}++;
    opendir my $dh, $dir or die;
    my @found = File::Spec->no_upwards(readdir $dh);
    closedir $dh;

    my @mods = grep /\.pm\z/ && -f File::Spec->catfile($dir, $_), @found;
    s/\.pm\z// for @mods;
    push @modules,
      grep !$modules{$_}++,
      map join('::', @pre, $_),
      grep !/\W/,
      @mods;

    unshift @search,
      map [ $_->[0], @pre, $_->[1] ],
      grep -d $_->[0],
      map [ File::Spec->catdir($dir, $_) => $_ ],
      grep !/\W/,
      @found;
  }

  return @modules;
}

sub _fh_has_encoding {
  my $fh = shift;
  return !!(
    defined &PerlIO::get_layers
    and grep $_ eq 'utf8', PerlIO::get_layers($fh)
  );
}

sub pod_coverage_ok {
  my $module = shift;
  my %opts = ref $_[0] eq 'HASH' ? %{ +shift } : ();
  my $msg = shift || "Pod coverage on $module";

  $opts{package} = $module;

  my $class = delete $opts{coverage_class} || 'Pod::Coverage::TrustMe';
  (my $mod = "$class.pm") =~ s{::}{/}g;
  require $mod;

  my $cover = $class->new(%opts);

  our $Test ||= Test::Builder->new;
  local $Test::Builder::Level = $Test::Builder::Level + 1;

  my $ok;
  my $extra;
  my $rating = $cover->coverage;
  if (!defined $rating) {
    my $why = $cover->why_unrated;
    my $symbols
      = $cover->can('symbols') ? $cover->symbols
      : do {
        # shim for using with Pod::Coverage subclasses rather than TrustMe
        my @symbs = $cover->_get_syms($module);
        $cover->why_unrated =~ /\Arequiring .* failed\z/
          ? undef : { map +($_ => 1), @symbs };
      };
    $ok = $Test->ok( defined $symbols && !%$symbols, $msg );
    $extra = "$module: $why";
  }
  else {
    $ok = $Test->is_eq((map sprintf('%3.0f%%', $_ * 100), $rating, 1), $msg);
    if (!$ok) {
      $extra = join('',
        "Naked subroutines:\n",
        map "    $_\n", sort $cover->uncovered,
      );
    }
  }
  if (defined $extra) {
    my $fh = $ok ? $Test->output : $Test->_diag_fh;
    if (!_fh_has_encoding($fh)) {
      utf8::encode($extra);
    }
    if ($ok) {
      $Test->note( $extra );
    }
    else {
      $Test->diag( $extra );
    }
  }
  return $ok;
}

sub all_pod_coverage_ok {
  my %opts = ref $_[0] eq 'HASH' ? %{ +shift } : ();
  my $dirs = delete $opts{dirs};
  my @modules = all_modules(@{ $dirs || [] });

  our $Test ||= Test::Builder->new;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $ok = 1;

  if ( @modules ) {
    $Test->plan( tests => scalar @modules );

    for my $module ( @modules ) {
      pod_coverage_ok( $module, @_ ) or $ok = 0;
    }
  }
  else {
    $Test->plan( tests => 1 );
    $Test->ok( 1, "No modules found." );
  }

  return $ok;
}

1;
__END__