File Coverage

blib/lib/Lingua/Stem/Uk.pm

Criterion	Covered	Total	%
statement	62	82	75.6
branch	14	38	36.8
condition	2	6	33.3
subroutine	10	12	83.3
pod	4	4	100.0
total	92	142	64.7

package Lingua::Stem::Uk;
use utf8;
use strict;


use strict;
use Exporter;
use Carp;
use vars qw (@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $VERSION);
BEGIN {
    @ISA         = qw (Exporter);
    @EXPORT      = ();
    @EXPORT_OK   = qw (stem stem_word clear_stem_cache stem_caching);
    %EXPORT_TAGS = ();
}
$VERSION = "0.01";

my $Stem_Caching  = 0;
my $Stem_Cache    = {};

my $VOWEL        = qr/аеіоуиєюяї/;
my $PERFECTIVEGROUND = qr/((ів|івши|івшись|ив|ивши|ившись)|((?<=[ая])(в|вши|вшись)))$/;
my $REFLEXIVE    = qr/(с[яь])$/;
my $ADJECTIVE    = qr/(ее|іе|ие|ое|ими|іми|ої|а|е|і|у|ю|ій|ий|ой|ем|ім|им|ом|его|ого|ему|ому|іх|их|ую|юю|ая|яя|ою|ею)$/;
my $PARTICIPLE   = qr/((івш|ивш|уюч|ьн|л)|((?<=[ая])(ем|нн|вш|ющ|щ)))$/;
my $VERB         = qr/((іла|ила|ена|ейте|уйте|іть|іли|или|ей|уй|іл|ил|ім|им|ен|іло|ило|ено|ять|ує|ують|іт|ит|ени|іть|ить|ую|ю)|((?<=[ая])(ла|на|ете|йте|ли|й|л|ем|н|ло|но|ет|ют|ны|ть|ешь|нно)))$/;
my $NOUN         = qr/(а|ев|ов|іе|ье|е|іями|ями|ами|еї|ії|и|ією|ею|єю|ой|ий|й|иям|ям|ием|ем|ам|ом|о|у|ах|іях|ях|и|і|ь|ію|ью|ю|ия|ья|я)$/;
my $RVRE         = qr/^(.*?[$VOWEL])(.*)$/;
my $DERIVATIONAL = qr/[^$VOWEL][$VOWEL]+[^$VOWEL]+[$VOWEL].*(?<=і)сть?$/;

sub stem {
    return [] if ($#_ == -1);
    my $parm_ref;
    if (ref $_[0]) {
        $parm_ref = shift;
    } else {
        $parm_ref = { @_ };
    }

    my $words      = [];
    my $locale     = 'uk';
    my $exceptions = {};
    foreach (keys %$parm_ref) {
        my $key = lc ($_);
        if ($key eq '-words') {
            @$words = @{$parm_ref->{$key}};
        } elsif ($key eq '-exceptions') {
            $exceptions = $parm_ref->{$key};
        } elsif ($key eq '-locale') {
            $locale = $parm_ref->{$key};
        } else {
            croak (__PACKAGE__ . "::stem() - Unknown parameter '$key' with value '$parm_ref->{$key}'\n");
        }
    }

    local( $_ );
    foreach (@$words) {
        # Flatten case
        $_ = lc $_;

        # Check against exceptions list
        if (exists $exceptions->{$_}) {
            $_ = $exceptions->{$_};
            next;
        }

        # Check against cache of stemmed words
        my $original_word = $_;
        if ($Stem_Caching && exists $Stem_Cache->{$original_word}) {
            $_ = $Stem_Cache->{$original_word};
            next;
        }

        $_ = stem_word($_);

        $Stem_Cache->{$original_word} = $_ if $Stem_Caching;
    }
    $Stem_Cache = {} if ($Stem_Caching < 2);

    return $words;
}

sub stem_word {
    my $word = lc shift;

    # Check against cache of stemmed words
    if ($Stem_Caching && exists $Stem_Cache->{$word}) {
        return $Stem_Cache->{$word};
    }

     my ($start, $RV) = $word =~ /$RVRE/;
     return $word unless $RV;

     # Step 1
     unless ($RV =~ s/$PERFECTIVEGROUND//) {
         $RV =~ s/$REFLEXIVE//;

         if ($RV =~ s/$ADJECTIVE//) {
             $RV =~ s/$PARTICIPLE//;
         } else {
             $RV =~ s/$NOUN// unless $RV =~ s/$VERB//;
         }
     }

     # Step 2
     $RV =~ s/и$//;

     # Step 3
     $RV =~ s/ість?$// if $RV =~ /$DERIVATIONAL/;

     # Step 4
     unless ($RV =~ s/ь$//) {
         $RV =~ s/іше?//;
         $RV =~ s/нн$/н/;
     }

     return $start.$RV;
}

sub stem_caching {
    my $parm_ref;
    if (ref $_[0]) {
        $parm_ref = shift;
    } else {
        $parm_ref = { @_ };
    }
    my $caching_level = $parm_ref->{-level};
    if (defined $caching_level) {
        if ($caching_level !~ m/^[012]$/) {
            croak(__PACKAGE__ . "::stem_caching() - Legal values are '0','1' or '2'. '$caching_level' is not a legal value");
        }
        $Stem_Caching = $caching_level;
    }
    return $Stem_Caching;
}

sub clear_stem_cache {
    $Stem_Cache = {};
}


1;
__END__