File Coverage

blib/lib/Lingua/Stem/Any.pm

Criterion	Covered	Total	%
statement	78	78	100.0
branch	26	32	81.2
condition	9	12	75.0
subroutine	23	23	100.0
pod	5	6	83.3
total	141	151	93.3

package Lingua::Stem::Any;

use v5.8.1;
use utf8;
use Carp;
use List::Util qw( any first );
use Unicode::CaseFold qw( fc );
use Unicode::Normalize qw( NFC );

use Moo;
use namespace::clean;

our $VERSION = '0.05';

my %language_alias = (
    nb => 'no',
    nn => 'no',
);

has language => (
    is      => 'rw',
    isa     => sub {
        croak "Language is not defined"  unless defined $_[0];
        croak "Invalid language '$_[0]'" unless _is_language($_[0]);
    },
    coerce  => sub { $_[0] && ($language_alias{lc $_[0]} || lc $_[0]) },
    trigger => 1,
    default => 'en',
);

has source => (
    is      => 'rw',
    isa     => sub {
        croak "Source is not defined"  unless defined $_[0];
        croak "Invalid source '$_[0]'" unless _is_source($_[0]);
    },
    trigger => 1,
);

has cache => (
    is      => 'rw',
    coerce  => sub { !!$_[0] },
    default => 0,
    trigger => 1,
);

has exceptions => (
    is      => 'rw',
    isa     => sub {
        croak 'Exceptions must be a hashref'
            if ref $_[0] ne 'HASH';
        croak 'Exceptions must only include hashref values'
            if any { ref $_ ne 'HASH' } values %{$_[0]};
    },
    default => sub { {} },
);

has normalize => (
    is      => 'rw',
    coerce  => sub { !!$_[0] },
    default => 1,
);

has casefold => (
    is      => 'rw',
    coerce  => sub { !!$_[0] },
    default => 1,
);

has _stemmer => (
    is      => 'ro',
    builder => '_build_stemmer',
    clearer => 1,
    lazy    => 1,
);

has _stemmers => (
    is      => 'ro',
    default => sub { {} },
);

has _cache_data => (
    is      => 'rw',
    default => sub { {} },
);

my %sources = (
    'Lingua::Stem::Snowball' => {
        languages => {map { $_ => 1 } qw(
            da de en es fi fr hu it la nl no pt ro ru sv tr
        )},
        builder => sub {
            my $language = shift;
            require Lingua::Stem::Snowball;
            my $stemmer = Lingua::Stem::Snowball->new(
                lang     => $language,
                encoding => 'UTF-8',
            );
            return {
                stem     => sub { $stemmer->stem(shift) },
                language => sub { $stemmer->lang(shift) },
            };
        },
    },
    'Lingua::Stem::UniNE' => {
        languages => {map { $_ => 1 } qw(
            bg cs de fa
        )},
        builder => sub {
            my $language = shift;
            require Lingua::Stem::UniNE;
            my $stemmer = Lingua::Stem::UniNE->new(language => $language);
            return {
                stem     => sub { $stemmer->stem(shift) },
                language => sub { $stemmer->language(shift) },
            };
        },
    },
    'Lingua::Stem' => {
        languages => {map { $_ => 1 } qw(
            da de en fr gl it no pt ru sv
        )},
        builder => sub {
            my $language = shift;
            require Lingua::Stem;
            my $stemmer = Lingua::Stem->new(-locale => $language);
            return {
                stem     => sub { @{ $stemmer->stem(shift) }[0] },
                language => sub { $stemmer->set_locale(shift) },
            };
        },
    },
    'Lingua::Stem::Patch' => {
        languages => {map { $_ => 1 } qw(
            eo io pl
        )},
        builder => sub {
            my $language = shift;
            require Lingua::Stem::Patch;
            my $stemmer = Lingua::Stem::Patch->new(language => $language);
            return {
                stem     => sub { $stemmer->stem(shift) },
                language => sub { $stemmer->language(shift) },
            };
        },
    },
);

my %languages = map { %{$_->{languages}} } values %sources;

my @source_order = qw(
    Lingua::Stem::Snowball
    Lingua::Stem::UniNE
    Lingua::Stem
    Lingua::Stem::Patch
);

# functions

sub _is_language { exists $languages{ $_[0] } }
sub _is_source   { exists $sources{   $_[0] } }

# methods

sub BUILD {
    my ($self) = @_;

    $self->_trigger_language;
}

# the stemmer is cleared whenever a language or source is updated
sub _trigger_language {
    my ($self) = @_;

    $self->_clear_stemmer;

    # keep current source if it supports this language
    return if $self->source
           && $sources{$self->source}{languages}{$self->language};

    # use the first supported source for this language
    $self->source(
        first { $sources{$_}{languages}{$self->language} } @source_order
    );
}

sub _trigger_source {
    my ($self) = @_;

    $self->_clear_stemmer;
}

# the stemmer is built lazily on first use
sub _build_stemmer {
    my ($self) = @_;

    croak sprintf "Invalid source '%s' for language '%s'" => (
        $self->source, $self->language
    ) unless $sources{$self->source}{languages}{$self->language};

    my $stemmer
        = $self->_stemmers->{$self->source}
            ||= $sources{$self->source}{builder}( $self->language );

    $stemmer->{language}( $self->language );

    return $stemmer;
}

sub _get_stem {
    my ($self, $word) = @_;
    my $exceptions = $self->exceptions->{$self->language};

    return $word unless $word;

    $word = fc  $word if $self->casefold;
    $word = NFC $word if $self->normalize;

    # get from exceptions
    return $exceptions->{$word}
        if $exceptions
        && exists $exceptions->{$word};

    # stem without caching
    return $self->_stemmer->{stem}($word)
        unless $self->cache;

    # get from cache
    return $self->_cache_data->{$self->source}{$self->language}{$word}
        if exists $self->_cache_data->{$self->source}{$self->language}{$word};

    # stem and add to cache
    return $self->_cache_data->{$self->source}{$self->language}{$word}
         = $self->_stemmer->{stem}($word);
}

sub stem {
    my $self = shift;

    return map { $self->_get_stem($_) } @_
        if wantarray;

    return $self->_get_stem(pop)
        if @_;

    return;
}

sub stem_in_place {
    my ($self, $words) = @_;

    croak 'Argument to stem_in_place() must be an arrayref'
        if ref $words ne 'ARRAY';

    for my $word (@$words) {
        $word = $self->_get_stem($word);
    }

    return;
}

sub languages {
    my ($self, $source) = @_;
    my @languages;

    if ($source && $sources{$source}) {
        @languages = sort keys %{$sources{$source}{languages}};
    }
    elsif (!$source) {
        @languages = sort keys %languages;
    }

    return @languages;
}

sub sources {
    my ($self, $language) = @_;

    return @source_order unless $language;

    return grep {
        $sources{$_} && $sources{$_}{languages}{$language}
    } @source_order;
}

sub clear_cache {
    my ($self) = @_;

    $self->_cache_data( {} );
}

sub _trigger_cache {
    my ($self) = @_;

    if ( !$self->cache ) {
        $self->clear_cache;
    }
}

1;

__END__