File Coverage

blib/lib/Module/CPANTS/Kwalitee/Pod.pm

Criterion	Covered	Total	%
statement	78	97	80.4
branch	43	64	67.1
condition	7	17	41.1
subroutine	11	13	84.6
pod	3	3	100.0
total	142	194	73.2

package Module::CPANTS::Kwalitee::Pod;
use warnings;
use strict;
use File::Spec::Functions qw/catfile/;
use Encode;
use Data::Binary qw/is_binary/;

our $VERSION = '1.02';
$VERSION =~ s/_//; ## no critic

our @ABSTRACT_STUBS = (
  q{Perl extension for blah blah blah}, # h2xs
  q{[One line description of module's purpose here]}, # Module::Starter etc
  q{The great new}, # Module::Starter
  q{It's new $module}, # Minilla
);

sub order { 100 }

##################################################################
# Analyse
##################################################################

sub analyse {
    my ($class, $me) = @_;
    my $distdir = $me->distdir;
    my @errors;

    my @files = map { $_->{file} } @{$me->d->{modules} || []};

    for my $file (@{$me->d->{files_array} || []}) {
        # sometimes pod for .pm file is put into .pod
        # and scripts may have abstract
        if (
            ( $file =~ /\.pod$/ && ($file =~ m!^lib/! or $file =~ m!^[^/]+$!) )
            or $file =~ m!^(?:bin|scripts?)/!
        ) {
            push @files, $file;
        }
    }

    for my $file (@files) {
        local $@;
        my ($package, $abstract, $error, $has_binary_data) = $class->_parse_abstract(catfile($distdir, $file));
        push @errors, "$error ($package)" if $error;
        $me->d->{abstracts_in_pod}{$package} = $abstract if $package;
        $me->d->{files_hash}{$file}{has_binary_data} = 1 if $has_binary_data;
    }
    $me->d->{error}{has_abstract_in_pod} = join ';', @errors if @errors;
}

# adapted from ExtUtils::MM_Unix and Module::Build::PodParser
sub _parse_abstract {
    my ($class, $file) = @_;
    my ($package, $abstract);
    my $inpod = 0;
    open my $fh, '<', $file or return;
    my $directive;
    my $encoding;
    my $package_name_pattern = '(?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ | [BCIF] < (?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ >';
    if ( $file !~ /\.p(?:m|od)$/ ) {
        $package_name_pattern .= ' | [A-Za-z0-9_.-]+ | [BCIF] < [A-Za-z0-9_.-]+ >';
    }
    while(<$fh>) {
        if (/^\s*__DATA__\s*$/) {
            my $copy = $_ = <$fh>;
            last unless defined $copy;
            return (undef, undef, undef, 1) if is_binary($copy);
        }
        if (substr($_, 0, 1) eq '=') {
            if (/^=encoding\s+(.+)/) {
                $encoding = $1;
            }
            if (/^=cut/) {
                $inpod = 0;
            } elsif (/^=(?!cut)(.+)/) {
                $directive = $1;
                $inpod = 1;
            }
        }
        next if !$inpod;
        next unless $directive =~ /^head/;
        if ( /^\s*(${package_name_pattern}) \s+ -+ (?:\s+ (.*)\s*$|$)/x ) {
            ($package, $abstract) = ($1, $2);
            $package =~ s![BCIF]<([^>]+)>!$1!;
            next;
        }
        next unless $abstract;
        last if /^\s*$/ || /^=/;
        s/\s+$//s;
        $abstract .= "\n$_";
    }

    my $error;
    if ($encoding && $abstract) {
        my $encoder = find_encoding($encoding);
        if (!$encoder) {
            $error = "unknown encoding: $encoding";
        } else {
            $abstract = eval { $encoder->decode($abstract) };
            if ($@) {
                $error = $@;
                $error =~ s|\s*at .+ line \d+.+$||s;
            }
        }
    }
    return ($package, $abstract, $error);
}

##################################################################
# Kwalitee Indicators
##################################################################

sub kwalitee_indicators {
    return [
      {
          name => 'has_abstract_in_pod',
          error => q{No abstract (short description of a module) is found in pod from this distribution.},
          remedy => q{Provide a short description in the NAME section of the pod (after the module name followed by a hyphen) at least for the main module of this distribution.},
          code => sub {
              my $d = shift;
              return 0 if $d->{error}{has_abstract_in_pod};
              my @abstracts = grep {defined $_ && length $_} values %{$d->{abstracts_in_pod} || {}};
              return @abstracts ? 1 : 0;
          },
          details => sub {
              my $d = shift;
              return "No abstracts in pod";
          },
      },
      {
          name => 'no_abstract_stub_in_pod',
          is_extra => 1,
          error => q{A well-known abstract stub (typically generated by an authoring tool) is found in this distribution.},
          remedy => q{Modify the stub. You might need to modify other stubs (for name, synopsis, license, etc) as well.},
          code => sub {
              my $d = shift;
              my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
              my @errors;
              for (sort keys %{$d->{abstracts_in_pod} || {}}) {
                  push @errors, $_ if $mapping{$d->{abstracts_in_pod}{$_} || ''};
              }
              if (@errors) {
                  $d->{error}{no_abstract_stub_in_pod} = join ',', @errors;
              }
              return @errors ? 0 : 1;
          },
          details => sub {
              my $d = shift;
              my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
              return "Abstracts in the following packages are stubs:". $d->{error}{no_abstract_stub_in_pod};
          },
      },
    ];
}


q{Favourite record of the moment:
  Fat Freddys Drop: Based on a true story};

__END__