File Coverage

blib/lib/Lingua/Stem/Patch/IO.pm
Criterion Covered Total %
statement 30 30 100.0
branch 12 12 100.0
condition n/a
subroutine 7 7 100.0
pod 0 2 0.0
total 49 51 96.0


line stmt bran cond sub pod time code
1             package Lingua::Stem::Patch::IO;
2              
3 4     4   143773 use v5.8.1;
  4         16  
  4         200  
4 4     4   25 use utf8;
  4         8  
  4         33  
5 4     4   88 use strict;
  4         9  
  4         138  
6 4     4   22 use warnings;
  4         8  
  4         157  
7 4     4   2641 use parent 'Exporter';
  4         1011  
  4         37  
8              
9             our $VERSION = '0.04';
10             our @EXPORT_OK = qw( stem stem_io stem_aggressive stem_io_aggressive );
11              
12             *stem_io = \&stem;
13             *stem_io_aggressive = \&stem_aggressive;
14              
15             my %protect = (
16             root => { map { $_ => 1 } qw(
17             la li me ni on vi
18             ) },
19             );
20              
21             sub stem {
22 117     117 0 21347 my $word = lc shift;
23              
24 117         253 for ($word) {
25             # standalone roots
26 117 100       405 last if $protect{root}{$word};
27              
28             # nouns: -on -i -in → -o
29 103 100       469 last if s{ (?: on | in? ) $}{o}x;
30              
31             # remove -u from pronouns: elu ilu olu onu
32 97 100       248 last if s{ (?<= ^ [eio] l | on ) u $}{}x;
33              
34             # pariciple adjectives: -inta -anta -onta -ita -ata -ota → -ar
35 89 100       218 last if s{ (?: [aio] n? t ) a $}{ar}x;
36              
37             # verbs: -ir -or -is -as -os -us -ez → -ar
38 77         203 s{ (?: [io] r | [aiou] s | ez ) $}{ar}x;
39              
40             # remove -ab- from verbs
41 77         231 s{ ab (?= ar $ ) }{}x;
42             }
43              
44 117         433 return $word;
45             }
46              
47             sub stem_aggressive {
48 58     58 0 13339 my $word = stem(shift);
49              
50 58         103 for ($word) {
51             # standalone roots
52 58 100       155 last if $protect{root}{$word};
53              
54             # remove final suffix
55 50         150 s{ (?: [aeo] | ar ) $}{}x;
56              
57             # remove -u from pronouns: elu ilu olu onu
58 50 100       223 last if s{ (?<= ^ [eio] l | on ) u $}{}x;
59             }
60              
61 58         232 return $word;
62             }
63              
64             1;
65              
66             __END__