File Coverage

blib/lib/Test/Spelling.pm

Criterion	Covered	Total	%
statement	86	139	61.8
branch	14	50	28.0
condition	4	15	26.6
subroutine	18	24	75.0
pod	9	11	81.8
total	131	239	54.8

package Test::Spelling;

use strict;
use warnings;

use Exporter qw(import);
use Pod::Spell;
use Test::Builder;
use Text::Wrap;
use File::Spec;
use IPC::Run3;
use Symbol 'gensym';

our $VERSION = '0.25';

our @EXPORT = qw(
    pod_file_spelling_ok
    all_pod_files_spelling_ok
    add_stopwords
    set_spell_cmd
    all_pod_files
    set_pod_file_filter
    has_working_spellchecker
    set_pod_parser
);

my $TEST = Test::Builder->new;

my $SPELLCHECKER;
my $FILE_FILTER = sub { 1 };
my $POD_PARSER;
our %ALL_WORDS;

sub spellchecker_candidates {
    # if they've specified a spellchecker, use only that one
    return $SPELLCHECKER if $SPELLCHECKER;

    return (
        'hunspell -l', # hunspell is now the most common spell checker
        'spell', # for back-compat, this is the top candidate ...
        'aspell list -l en -p /dev/null', # ... but this should become first soon
        'ispell -l',
    );
}

sub has_working_spellchecker {
    my $dryrun_results = _get_spellcheck_results("dry run", 1);

    if (ref $dryrun_results) {
        return;
    }

    return $SPELLCHECKER;
}

sub _get_spellcheck_results {
    my $document = shift;
    my $dryrun = shift;

    my @errors;

    for my $spellchecker (spellchecker_candidates()) {
        my @words;
        my $ok = eval {

            my ($spellcheck_results, $errors);
            IPC::Run3::run3($spellchecker, \$document, \$spellcheck_results, \$errors);

            @words = split /\n/, $spellcheck_results;

            die "spellchecker had errors: $errors" if length $errors;

            1;
        };

        if ($ok) {
            # remember the one we used, so that it's consistent for all the files
            # this run, and we don't keep retrying the same spellcheckers that will
            # never work. also we need to expose the spellchecker we're using in
            # has_working_spellchecker
            set_spell_cmd($spellchecker)
                if !$SPELLCHECKER;
            return @words;
        }

        push @errors, "Unable to run '$spellchecker': $@";
    }

    # no working spellcheckers during a dry run
    return \"no spellchecker" if $dryrun;

    # no working spellcheckers; report all the errors
    require Carp;
    Carp::croak
        "Unable to find a working spellchecker:\n"
        . join("\n", map { "    $_\n" } @errors)
}

sub invalid_words_in {
    my $file = shift;

    my $document = '';
    open my $handle, '>', \$document;
    # the UTF-8 parsing seems to have broken many tests
    #open my $infile, '<:encoding(UTF-8)', $file;

    # save digested POD to the string $document
    #get_pod_parser()->parse_from_filehandle($infile, $handle);
    get_pod_parser()->parse_from_file($file, $handle);
    my @words = _get_spellcheck_results($document);

    chomp for @words;
    return @words;
}

sub pod_file_spelling_ok {
    my $file = shift;
    my $name = shift || "POD spelling for $file";

    if (!-r $file) {
        $TEST->ok(0, $name);
        $TEST->diag("$file does not exist or is unreadable");
        return;
    }

    my @words = invalid_words_in($file);

    # remove stopwords, select unique errors
    my $WL = \%Pod::Wordlist::Wordlist;
    @words = grep { !$WL->{$_} && !$WL->{lc $_} } @words;
    $ALL_WORDS{$_}++ for @words;
    my %seen;
    @seen{@words} = ();
    @words = sort keys %seen;

    # emit output
    my $ok = @words == 0;
    $TEST->ok($ok, "$name");
    if (!$ok) {
        $TEST->diag("Errors:\n" . join '', map { "    $_\n" } @words);
    }

    return $ok;
}

sub all_pod_files_spelling_ok {
    my @files = all_pod_files(@_);
    local %ALL_WORDS;
    if (!has_working_spellchecker()) {
        return $TEST->plan(skip_all => "no working spellchecker found");
    }

    $TEST->plan(tests => scalar @files);

    my $ok = 1;
    for my $file (@files) {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        pod_file_spelling_ok($file) or undef $ok;
    }
    if ( keys %ALL_WORDS ) {
        # Invert k => v to v => [ k ]
        my %values;
        push @{ $values{ $ALL_WORDS{$_} } }, $_ for keys %ALL_WORDS;

        my $labelformat = q[%6s: ];
        my $indent      = q[ ] x 10;

        $TEST->diag(qq[\nAll incorrect words, by number of occurrences:\n] .
          join qq[\n], map { wrap( ( sprintf $labelformat, $_ ), $indent, join q[, ], sort @{ $values{$_} } ) }
          sort { $a <=> $b } keys %values
        );
    }
    return $ok;
}

sub all_pod_files {
    my @queue = @_ ? @_ : _starting_points();
    my @pod;

    while (@queue) {
        my $file = shift @queue;

        # recurse into subdirectories
        if (-d $file) {
            opendir(my $dirhandle, $file) or next;
            my @newfiles = readdir($dirhandle);
            closedir $dirhandle;

            @newfiles = File::Spec->no_upwards(@newfiles);
            @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles;

            push @queue, map "$file/$_", @newfiles;
        }

        # add the file if it meets our criteria
        if (-f $file) {
            next unless _is_perl($file);
            next unless $FILE_FILTER->($file);
            push @pod, $file;
        }
    }

    return @pod;
}

sub _starting_points {
    return 'blib' if -d 'blib';
    return 'lib';
}

sub _is_perl {
    my $file = shift;

    return 1 if $file =~ /\.PL$/;
    return 1 if $file =~ /\.p(l|lx|m|od)$/;
    return 1 if $file =~ /\.t$/;

    open my $handle, '<', $file or return;
    my $first = <$handle>;

    return 1 if defined $first && ($first =~ /^#!.*perl/);

    return 0;
}

sub add_stopwords {
    for (@_) {
        # explicit copy so we don't modify constants as in add_stopwords("SQLite")
        my $word = $_;

        # XXX: the processing this performs is to support "perl t/spell.t 2>>
        # t/spell.t" which is bunk. in the near future the processing here will
        # become more modern
        $word =~ s/^#?\s*//;
        $word =~ s/\s+$//;
        next if $word =~ /\s/ or $word =~ /:/;
        $Pod::Wordlist::Wordlist{$word} = 1;
    }
}

sub set_spell_cmd {
    $SPELLCHECKER = shift;
}

sub set_pod_file_filter {
    $FILE_FILTER = shift;
}

# A new Pod::Spell object should be used for every file; people
# providing custom pod parsers will have to do this themselves
sub get_pod_parser {
    return $POD_PARSER || Pod::Spell->new;
}

sub set_pod_parser {
    $POD_PARSER = shift;
}

1;

__END__