File Coverage

blib/lib/Pod/Wordlist.pm

Criterion	Covered	Total	%
statement	96	97	98.9
branch	39	44	88.6
condition	13	15	86.6
subroutine	14	14	100.0
pod	3	3	100.0
total	165	173	95.3

package Pod::Wordlist;
use 5.008;
use strict;
use warnings;

our $VERSION = '1.25';

use Lingua::EN::Inflect 'PL';
use File::Spec ();
use constant {
    MAXWORDLENGTH => 50,
};

use Class::Tiny {
    wordlist  => \&_copy_wordlist,
    _is_debug => 0,
    no_wide_chars => 0,
};

our %Wordlist; ## no critic ( Variables::ProhibitPackageVars )

sub _copy_wordlist {
    my %copy;

    # %Wordlist can be accessed externally, and users will often add terms in
    # encoded form
    for my $word ( keys %Wordlist ) {
        my $decoded_word = $word;
        # if it was already decoded, this should do nothing
        utf8::decode($decoded_word);
        $copy{$decoded_word} = 1;
    }

    return \%copy;
}

BEGIN {
    my $file;

    # try to find wordlist in non-installed dist
    my ($d, $p) = File::Spec->splitpath(__FILE__);
    $p = File::Spec->catdir($p, (File::Spec->updir) x 2, 'share');
    my $full_path = File::Spec->catpath($d, $p, 'wordlist');
    if ($full_path && -e $full_path) {
        $file = $full_path;
    }

    if ( not defined $file ) {
        require File::ShareDir;
        $file = File::ShareDir::dist_file('Pod-Spell', 'wordlist');
    }

    open my $fh, '<:encoding(UTF-8)', $file
        or die "Cannot read $file: $!"; ## no critic (ErrorHandling::RequireCarping)
    while ( defined( my $line = readline $fh ) ) {
        chomp $line;
        $Wordlist{$line} = 1;
        $Wordlist{PL($line)} = 1;
    }
    close $fh;
}

sub learn_stopwords {
    my ( $self, $text ) = @_;
    my $stopwords = $self->wordlist;

    while ( $text =~ m<(\S+)>g ) {
        my $word = $1;
        utf8::decode($word);
        if ( $word =~ m/^!(.+)/s ) {
            # "!word" deletes from the stopword list
            my $negation = $1;
            # different $1 from above
            delete $stopwords->{$negation};
            delete $stopwords->{PL($negation)};
            print "Unlearning stopword <$negation>\n" if $self->_is_debug;
        }
        else {
            $word =~ s{'s$}{}; # we strip 's when checking so strip here, too
            $stopwords->{$word} = 1;
            $stopwords->{PL($word)} = 1;
            print "Learning stopword   <$word>\n" if $self->_is_debug;
        }
    }
    return;
}

sub is_stopword {
    my ($self, $word) = @_;
    my $stopwords = $self->wordlist;
    if ( exists $stopwords->{$word} or exists $stopwords->{ lc $word } ) {
        print "  Rejecting   <$word>\n" if $self->_is_debug;
        return 1;
    }
    return;
}

sub strip_stopwords {
    my ($self, $text) = @_;

    # Count the things in $text
    print "Content: <", $text, ">\n" if $self->_is_debug;

    my @words = grep { length($_) < MAXWORDLENGTH } split " ", $text;

    for ( @words ) {
        print "Parsing word: <$_>\n" if $self->_is_debug;
        # some spellcheckers can't cope with anything but Latin1
        $_ = '' if $self->no_wide_chars && /[^\x00-\xFF]/;

        # strip leading punctuation
        s/^[\(\[\{\'\"\:\;\,\?\!\.]+//;

        # keep everything up to trailing punctuation, not counting
        # periods (for abbreviations like "Ph.D."), single-quotes
        # (for contractions like "don't") or colons (for package
        # names like "Foo::Bar")
        s/^([^\)\]\}\"\;\,\?\!]+).*$/$1/;

        # strip trailing single-quote, periods or colons; after this
        # we have a word that could have internal periods or quotes
        s/[\.\'\:]+$//;

        # strip possessive
        s/'s$//i;

        # zero out variable names or things with internal symbols,
        # since those are probably code expressions outside a C<>
        my $is_sigil   = /^[\&\%\$\@\:\<\*\\\_]/;
        my $is_strange = /[\%\^\&\#\$\@\_\<\>\(\)\[\]\{\}\\\*\:\+\/\=\|\`\~]/;
        $_ = '' if $is_sigil || $is_strange;

        # stop if there are no "word" characters left; if it's just
        # punctuation that we didn't happen to strip or it's weird glyphs,
        # the spellchecker won't do any good anyway
        next unless /\w/;

        print "  Checking as <$_>\n" if $self->_is_debug;

        # replace it with any stopword or stopword parts stripped
        $_ = $self->_strip_a_word($_);

        print "  Keeping as  <$_>\n" if $_ && $self->_is_debug;
    }

    return join(" ", grep { defined && length } @words );
}

sub _strip_a_word {
    my ($self, $word) = @_;
    my $remainder;

    # try word as-is, including possible hyphenation vs stoplist
    if ($self->is_stopword($word) ) {
        $remainder = '';
    }
    # internal period could be abbreviations, so check with
    # trailing period restored and drop or keep on that basis
    elsif ( index($word, '.') >= 0 ) {
        my $abbr = "$word.";
        $remainder = $self->is_stopword($abbr) ? '' : $abbr;
    }
    # check individual parts of hyphenated word, keep whatever isn't a
    # stopword as individual words
    elsif ( index($word, '-') >= 0 ) {
        my @keep;
        for my $part ( split /-/, $word ) {
            push @keep, $part if ! $self->is_stopword( $part );
        }
        $remainder = join(" ", @keep) if @keep;
    }
    # otherwise, we just keep it
    else {
        $remainder = $word;
    }
    return $remainder;
}

1;

__END__