File Coverage

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

Criterion	Covered	Total	%
statement	81	92	88.0
branch	14	26	53.8
condition	11	29	37.9
subroutine	12	12	100.0
pod	3	3	100.0
total	121	162	74.6

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

our $VERSION = '0.001_001';
$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 pod_coverage_ok {
  my $module = shift;
  my $opts = ref $_[0] eq 'HASH' ? shift : {};
  my $msg = shift || "Pod coverage on $module";

  my %opts = (
    %$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 $rating = $cover->coverage;
  if (!defined $rating) {
    my $why = $cover->why_unrated;
    $ok = $Test->ok( defined $cover->symbols, $msg );
    $Test->diag( "$module: ". $cover->why_unrated );
  }
  else {
    $ok = $Test->is_eq((map sprintf('%3.0f%%', $_ * 100), $rating, 1), $msg);
    if (!$ok) {
      $Test->diag(join('',
        "Naked subroutines:\n",
        map "    $_\n", $cover->uncovered,
      ));
    }
  }
  return $ok;
}

sub all_pod_coverage_ok {
  my @modules = all_modules();

  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__