File Coverage

blib/lib/Text/Unmunch.pm
Criterion Covered Total %
statement 183 246 74.3
branch 77 126 61.1
condition 20 30 66.6
subroutine 18 22 81.8
pod 2 19 10.5
total 300 443 67.7


line stmt bran cond sub pod time code
1             # Copyrights 2020 by [Eleonora ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.01.
5             package Text::Unmunch;
6              
7             our $VERSION = 0.1;
8              
9 1     1   72536 use strict;
  1         2  
  1         31  
10 1     1   5 use warnings;
  1         2  
  1         28  
11 1     1   612 use open qw( :encoding(UTF-8) :std );
  1         1255  
  1         6  
12              
13             sub new{
14 1     1 1 91 my ($class,$args) = @_;
15             my $self = bless { aff => $args->{aff},
16             wf => $args->{wf},
17             sfx => $args->{sfx},
18             pfx => $args->{pfx},
19             debug => $args->{debug},
20 1         10 debug_class => 0,
21             }, $class;
22              
23             }
24              
25             sub check_args{
26 4     4 0 6 my $self = shift;
27            
28 4 50 33     25 if (not defined $self->{aff} or not defined $self->{wf}){
29 0         0 die "affix file and word file must be defined\n";
30             }
31 4 50 33     118 if( not -e $self->{aff} or not -e $self->{wf}){
32 0         0 die "either $self->{aff} or $self->{wf} does not exist\n";
33             }
34 4 50       15 if(not defined $self->{debug}){
35 0         0 $self->{debug} = '';
36             }
37 4 50       11 if($self->{debug} ne ""){
38 4         11 $self->{debug_class} = substr($self->{debug}, 3);
39             }
40 4 50       20 if(not defined $self->{sfx}){
    100          
41 0         0 $self->{sfx} = '';
42             } elsif(length($self->{sfx}) > 1){
43 1         11 $self->{sfx} = substr( $self->{sfx}, 1);
44             }
45 4 50       14 if(not defined $self->{pfx}){
    100          
46 0         0 $self->{pfx} = '';
47             } elsif(length($self->{pfx}) > 1){
48 1         6 $self->{pfx} = substr( $self->{pfx}, 1);
49             }
50            
51 4 100 100     17 if($self->{sfx} ne '' and $self->{sfx} eq 's'){
52 1         3 $self->{sfx} = 1;
53             }
54 4 100 100     16 if($self->{pfx} ne '' and $self->{pfx} eq 'p'){
55 1         2 $self->{pfx} = 1;
56             }
57 4 100 66     14 if(($self->{sfx} eq '') and ($self->{pfx} eq '')){
58 1         3 $self->{pfx} = 1;
59 1         3 $self->{sfx} = 1;
60             }
61 4 100       14 if($self->{debug_class} >= 2){
62 1         10 print "r_s:$self->{sfx} r_p:$self->{pfx} deb:$self->{debug} af:$self->{aff} wf:$self->{wf}\n";
63             }
64            
65             }
66              
67             # get aff file
68             sub get_aff{
69 1     1 0 756 my $self = shift;
70 1         7 return $self->{aff};
71             }
72              
73             # set aff file
74             sub set_aff{
75 0     0 0 0 my ($self,$new_aff) = @_;
76 0         0 $self->{aff} = $new_aff;
77             }
78              
79             # get wf
80             sub get_wf{
81 1     1 0 2 my $self = shift;
82 1         5 return $self->{wf};
83             }
84              
85             # set wf
86             sub set_wf{
87 0     0 0 0 my ($self,$new_wf) = @_;
88 0         0 $self->{wf} = $new_wf;
89             }
90             # get sfx
91             sub get_sfx{
92 1     1 0 3 my $self = shift;
93 1         4 return $self->{sfx};
94             }
95             # set sfx
96             sub set_sfx{
97 1     1 0 599 my ($self,$new_sfx) = @_;
98 1         3 $self->{sfx} = $new_sfx;
99             }
100             # get pfx
101             sub get_pfx{
102 1     1 0 3 my $self = shift;
103 1         4 return $self->{pfx};
104             }
105             # set pfx
106             sub set_pfx{
107 1     1 0 599 my ($self,$new_pfx) = @_;
108 1         4 $self->{pfx} = $new_pfx;
109             }
110             # get debug
111             sub get_debug{
112 1     1 0 2 my $self = shift;
113 1         5 return $self->{debug};
114             }
115             # set debug
116             sub set_debug{
117 1     1 0 703 my ($self,$new_debug) = @_;
118 1         3 $self->{debug} = $new_debug;
119             }
120             # return formatted string of the product
121             sub to_string{
122 0     0 0 0 my $self = shift;
123            
124 0         0 return "aff: $self->{aff}\nwf: $self->{wf}\nsfx: $self->{sfx}\npfx: $self->{pfx}\ndebug: $self->{debug}\ndebug_class: $self->{debug_class}\n";
125             }
126              
127             sub get_endings{
128 4     4 1 949 my $self = shift;
129 4         12 my ($sfxptr, $hashptr);
130 4         0 my (@sfx_arr, @pfx_arr);
131            
132 4         14 check_args($self);
133              
134 4         12 ($sfxptr,$hashptr) = read_in_sfx($self->{aff}, $self->{debug_class});
135            
136            
137 4 50       126 open(FH, '<', $self->{wf}) or die $!;
138              
139 4         354 while(){
140 8         74 my @warr = split(/\//, $_);
141 8         17 my $szo = $warr[0];
142 8         11 my $flags = $warr[1];
143 8         18 my @flarr = split(//, $flags);
144 8 50       19 if($self->{debug_class} >= 3){
145 0         0 print "szo:$szo flags:$flags\n";
146             }
147 8         32 foreach(@flarr){
148             # get sfx index
149 24         48 my $idx = $hashptr->{$_};
150 24 100       43 if(defined($idx)){
151 20 100       36 if($self->{debug_class} >= 2){
152 5         29 print "tag = $_ idx:$idx\n";
153             }
154 20         39 my $count = $sfxptr->[$idx]{'count'};
155 20         44 my $type = $sfxptr->[$idx]{'type'};
156 20         26 my $comb = $sfxptr->[$idx]{'comb'};
157             # print "idx:$idx cnt=$count\n";
158 20         41 for (my $i=0; $i < $count; $i++){
159 44         67 my ($strip, $addtoword, $cond);
160 44         68 $strip = $sfxptr->[$idx]{'elements'}->[$i]{'strip'};
161 44         56 $addtoword = $sfxptr->[$idx]{'elements'}->[$i]{'add_to_word'};
162 44         63 $cond = $sfxptr->[$idx]{'elements'}->[$i]{'condition'};
163 44 50       72 if($self->{debug_class} >=3){
164 0         0 print "idx:$idx cnt=$count strip:$strip atw:$addtoword cond:$cond->[0]\n";
165             }
166 44 100       79 if(met_cond($szo, $cond, $type,$self->{debug_class})){
167 20         32 my $ujszo;
168 20 100       40 if($type eq 's'){
    50          
169 16         27 $ujszo = strip_add_sfx($szo, $strip, $addtoword);
170 16         31 push(@sfx_arr,$ujszo );
171             } elsif($type eq 'p'){
172 4 50 33     14 if($comb eq 'y' or $comb eq 'Y'){
173 4         9 push( @pfx_arr, $addtoword);
174             } else{
175 0         0 $ujszo = strip_add_pfx($szo, $strip, $addtoword);
176             }
177             }
178 20 100 66     70 if($self->{sfx} and defined($ujszo)){print "$ujszo\n";}
  16         74  
179             }
180             }
181             }
182             } # flarr
183 8 100       33 if($self->{pfx}){
184 6 50       17 if($self->{pfx}){
185 6         11 foreach(@pfx_arr){
186 3         12 my $pfx = $_;
187 3         5 foreach(@sfx_arr){
188 6         11 my $ujszo = $pfx.$_;
189 6 50       12 if(defined($ujszo)){print "$ujszo\n";}
  6         18  
190             }
191             }
192             }
193             } # r_prefix
194 8         13 @sfx_arr = ();
195 8         74 @pfx_arr = ();
196              
197            
198             }
199              
200 4         193 close(FH);
201            
202            
203             }
204              
205              
206             sub read_in_sfx{
207 4     4 0 9 my($affixfile, $debug) = @_;
208            
209 4         7 my $new = 1;
210 4         7 my (@sfx);
211             my ($idx);
212 4         6 $idx = 0;
213 4         6 my $counter = 0;
214             #my $debug = 2;
215 4         13 my %shash;
216            
217 4 50       123 open(FH, '<', $affixfile) or die $!;
218              
219 4         404 while(){
220 1864 100 100     7457 if(index($_, "SFX ") == 0 or index($_, "PFX ") == 0){
221 292 50       487 if($debug >=4){
222 0         0 print $_;
223             }
224 292 100       429 if($new){
225 92         350 my @fields = split( /\s{1,}/, $_);
226 92         125 my @newarr;
227             # print Dumper (\@fields);
228 92         238 $sfx[$idx]{'count'} = $fields[3];
229 92         145 $sfx[$idx]{'id'} = $fields[1];
230 92         144 $sfx[$idx]{'comb'} = $fields[2];
231 92         199 $shash{$fields[1]} = $idx;
232 92 100       165 if($fields[0] eq 'SFX'){
233 64         101 $sfx[$idx]{'type'} = 's';
234             } else{
235 28         42 $sfx[$idx]{'type'} = 'p';
236             }
237 92         126 $sfx[$idx]{'elements'} = \@newarr;
238 92         274 $new = 0;
239             } else{
240 200         820 my @fields = split( /\s{1,}/, $_);
241 200         332 my $r = $sfx[$idx]{'elements'};
242 200         321 my @newarr = @$r;
243 200         444 $newarr[$counter]{'strip'} = $fields[2];
244             #
245             # strip /.. from prefix
246             #
247 200         395 my @tmparr = split(/\//, $fields[3]);
248 200         350 $newarr[$counter]{'add_to_word'} = $tmparr[0];
249 200         304 $newarr[$counter]{'condition'} = read_cond($fields[4], $debug);
250 200         302 $sfx[$idx]{'elements'} = \@newarr;
251 200         272 ++ $counter;
252 200 100       620 if($counter eq $sfx[$idx]{'count'}){
253 92         117 $new = 1;
254 92         105 $counter = 0;
255 92         264 ++$idx;
256             }
257            
258             }
259             }
260             }
261              
262 4         55 close(FH);
263              
264 4         23 return (\@sfx, \%shash);
265             }
266              
267              
268             sub read_cond{
269 200     200 0 320 my($condition, $debug) = @_;
270            
271 200         234 my @carr;
272            
273 200         239 my $in_loop = 0;
274 200         429 my @condarr = split(//, $condition);
275 200         255 my ($tcarr);
276 200         286 foreach (@condarr){
277 828 100       1421 if ($_ eq '['){
    100          
278 108 50       158 if(!$in_loop){
279 108         159 $in_loop = 1;
280             } else {
281 0         0 print "error1 in condition $condition\n";
282             }
283             }
284             elsif($_ eq ']'){
285 108 50       138 if($in_loop) {
286 108         210 push(@carr, $tcarr);
287 108         159 $in_loop = 0;
288 108         166 $tcarr = '';
289             }else {
290 0         0 print "error2 in condition $condition\n";
291             }
292             }else {
293 612 100       824 if($in_loop){
294 464         648 $tcarr .= $_;
295             }else{
296 148         327 push(@carr, $_);
297             }
298             }
299            
300             }
301 200 50       342 if($debug >=4){
302 0         0 my $condarrsize = @carr;
303 0         0 my $i;
304 0         0 print "carr: $condarrsize\n";
305 0         0 for ($i = 0; $i < $condarrsize; $i++){
306 0         0 print "$i $carr[$i]\n";
307             }
308             }
309 200         475 return \@carr;
310            
311             }
312              
313             sub met_cond{
314 44     44 0 71 my($szo, $condref, $type, $debug) = @_;
315            
316 44         81 my @carr = @$condref;
317 44         53 my $condarrsize = @carr;
318 44 50       82 if($debug >=5){
319 0         0 print "condarrsize:$condarrsize\n";
320             }
321            
322 44 100 66     117 if($carr[0] eq '.' and $condarrsize == 1 ){
    50          
    0          
323 12         37 return 1;
324             }elsif ($type eq 's'){
325 32         53 my $lszo = length($szo);
326 32         43 my $szoidx = $lszo - 1;
327 32         39 my $i;
328 32         52 for($i = $condarrsize -1; $i >=0; $i--){
329 40         91 my $tobechecked = substr($szo, $szoidx, 1);
330 40 50       64 if($debug >= 4){
331 0         0 print "tbc:$tobechecked szdx:$szoidx ci:$carr[$i]\n";
332             }
333 40 100       77 if(length($carr[$i]) == 1){
334 16 100 66     48 if ( $carr[$i] ne $tobechecked and $carr[$i] ne '.'){
335 8 50       11 if($debug >= 3){
336 0         0 print "no match1\n";
337             }
338 8         27 return 0;
339             }
340             } else{
341 24         78 my $j ;
342 24         33 my $matched = 0;
343 24         28 my $clen = length($carr[$i]);
344 24 100       46 if(substr($carr[$i],0,1) eq '^'){ # inverted check
345 12         26 for($j = 1; $j < $clen; $j++){
346 60 100       127 if(substr($carr[$i],$j,1) eq $tobechecked){
347 4 50       29 if($debug >= 3){
348 0         0 print "no match2\n";
349             }
350 4         17 return 0;
351             }
352             }
353 8         12 $matched = 1;
354             } else{ # at least one matches
355 12         20 for($j = 1; $j < $clen; $j++){
356 40 50       90 if(substr($carr[$i],$j,1) eq $tobechecked){
357 0         0 $matched = 1;
358 0         0 last;
359             }
360             }
361             }
362 20 100       34 if($matched eq 0){
363 12 50       31 if($debug >= 3){
364 0         0 print "no match3 i= $i szi: $szoidx tbc:$tobechecked\n";
365             }
366 12         42 return 0;
367             }
368             }
369 16         32 --$szoidx;
370             }
371            
372             } elsif($type eq 'p'){
373 0         0 my $szoidx = 0;
374 0         0 my $i;
375 0         0 for($i = 0; $i <= $condarrsize -1; $i++){
376 0         0 my $tobechecked = substr($szo, $szoidx, 1);
377 0 0       0 if($debug >= 4){
378 0         0 print "tbc:$tobechecked szdx:$szoidx ci:$carr[$i]\n";
379             }
380 0 0       0 if(length($carr[$i]) == 1){
381 0 0       0 if ( $carr[$i] ne $tobechecked ){
382 0 0       0 if($debug >= 3){
383 0         0 print "no match1\n";
384             }
385 0         0 return 0;
386             }
387             } else{
388 0         0 my $j ;
389 0         0 my $matched = 0;
390 0         0 my $clen = length($carr[$i]);
391 0 0       0 if(substr($carr[$i],0,1) eq '^'){ # inverted check
392 0         0 for($j = 1; $j < $clen; $j++){
393 0 0       0 if(substr($carr[$i],$j,1) eq $tobechecked){
394 0 0       0 if($debug >= 3){
395 0         0 print "no match2\n";
396             }
397 0         0 return 0;
398             }
399             }
400 0         0 $matched = 1;
401             } else{ # at least one matches
402 0         0 for($j = 1; $j < $clen; $j++){
403 0 0       0 if(substr($carr[$i],$j,1) eq $tobechecked){
404 0         0 $matched = 1;
405 0         0 last;
406             }
407             }
408             }
409 0 0       0 if($matched eq 0){
410 0 0       0 if($debug >= 3){
411 0         0 print "no match3 i= $i szi: $szoidx tbc:$tobechecked\n";
412             }
413 0         0 return 0;
414             }
415             }
416 0         0 ++$szoidx;
417             }
418            
419             }
420 8         23 return 1;
421            
422             }
423             sub strip_add_sfx{
424 16     16 0 30 my($szo, $strip, $atw) = @_;
425 16 100       33 if($strip ne '0'){
426 4         13 $szo = substr($szo, 0, (length($szo)-length($strip)));
427             }
428 16         36 return $szo.$atw;
429              
430             }
431             sub strip_add_pfx{
432 0     0 0   my($szo, $strip, $atw) = @_;
433 0 0         if($strip ne '0'){
434 0           $szo = substr($szo, 0, (length($szo)-length($strip)));
435             }
436 0           return $atw.$szo;
437              
438             }
439              
440             1;
441              
442             __END__