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

# Copyrights 2020 by [Eleonora ].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.01.
package Text::Unmunch;

our $VERSION = 0.2;

use strict;
use warnings;
use open qw( :encoding(UTF-8) :std );

sub new{
    my ($class,$args) = @_;
    my $self = bless { aff => $args->{aff},
                       wf => $args->{wf},
                       sfx => $args->{sfx},
                       pfx => $args->{pfx},
                       debug    => $args->{debug},
                       debug_class => 0,
                     }, $class;

}

sub check_args{
   my $self = shift;

   if (not defined $self->{aff} or not defined $self->{wf}){
     die "affix file and word file must be defined\n";
   }
    if(   not -e $self->{aff} or not -e $self->{wf}){
     die "either $self->{aff} or $self->{wf} does not exist\n";
   }
   if(not defined $self->{debug}){
      $self->{debug} = '';
   }
   if($self->{debug} ne ""){
      $self->{debug_class} = substr($self->{debug}, 3);
   }
   if(not defined $self->{sfx}){
      $self->{sfx} = '';
   } elsif(length($self->{sfx}) > 1){
     $self->{sfx} = substr( $self->{sfx}, 1);
   }
   if(not defined $self->{pfx}){
      $self->{pfx} = '';
   } elsif(length($self->{pfx}) > 1){
     $self->{pfx} = substr( $self->{pfx}, 1);
   }

   if($self->{sfx} ne '' and $self->{sfx} eq 's'){
     $self->{sfx} = 1;
   }
   if($self->{pfx} ne '' and $self->{pfx} eq 'p'){
     $self->{pfx} = 1;
   }
   if(($self->{sfx} eq '') and ($self->{pfx} eq '')){
     $self->{pfx} = 1;
     $self->{sfx} = 1;
   }
   if($self->{debug_class} >= 2){
     print "r_s:$self->{sfx} r_p:$self->{pfx} deb:$self->{debug} af:$self->{aff} wf:$self->{wf}\n";
   }

}

# get aff file
sub get_aff{
   my $self = shift;
   return $self->{aff};
}

# set aff file
sub set_aff{
   my ($self,$new_aff) = @_;
   $self->{aff} = $new_aff;
}

# get wf
sub get_wf{
   my $self = shift;
   return $self->{wf};
}

# set wf
sub set_wf{
   my ($self,$new_wf) = @_;
   $self->{wf} = $new_wf;
}
# get sfx
sub get_sfx{
   my $self = shift;
   return $self->{sfx};
}
# set sfx
sub set_sfx{
   my ($self,$new_sfx) = @_;
   $self->{sfx} = $new_sfx;
}
# get pfx
sub get_pfx{
   my $self = shift;
   return $self->{pfx};
}
# set pfx
sub set_pfx{
   my ($self,$new_pfx) = @_;
   $self->{pfx} = $new_pfx;
}
# get debug
sub get_debug{
   my $self = shift;
   return $self->{debug};
}
# set debug
sub set_debug{
   my ($self,$new_debug) = @_;
   $self->{debug} = $new_debug;
}
# return formatted string of the product
sub to_string{
   my $self = shift;

   return "aff: $self->{aff}\nwf: $self->{wf}\nsfx: $self->{sfx}\npfx: $self->{pfx}\ndebug: $self->{debug}\ndebug_class: $self->{debug_class}\n";
}

sub get_endings{
   my $self = shift;
   my ($sfxptr, $hashptr);
   my (@sfx_arr, @pfx_arr);

   check_args($self);

   ($sfxptr,$hashptr) = read_in_sfx($self->{aff}, $self->{debug_class});


   open(FH, '<', $self->{wf}) or die $!;

while(){
  my @warr = split(/\//, $_);
  my $szo = $warr[0];
  my $flags = $warr[1];
  my @flarr = split(//, $flags);
   if($self->{debug_class} >= 3){
     print "szo:$szo flags:$flags\n";
   }
  foreach(@flarr){
    # get sfx index
     my $idx = $hashptr->{$_};
    if(defined($idx)){
      if($self->{debug_class} >= 2){
      print "tag = $_ idx:$idx\n";
      }
      my $count = $sfxptr->[$idx]{'count'};
      my $type  = $sfxptr->[$idx]{'type'};
      my $comb  = $sfxptr->[$idx]{'comb'};
    #   print "idx:$idx cnt=$count\n";
      for (my $i=0; $i < $count; $i++){
        my ($strip, $addtoword, $cond);
        $strip     = $sfxptr->[$idx]{'elements'}->[$i]{'strip'};
        $addtoword = $sfxptr->[$idx]{'elements'}->[$i]{'add_to_word'};
        $cond      = $sfxptr->[$idx]{'elements'}->[$i]{'condition'};
         if($self->{debug_class} >=3){
         print "idx:$idx cnt=$count strip:$strip atw:$addtoword cond:$cond->[0]\n";
         }
         if(met_cond($szo, $cond, $type,$self->{debug_class})){
             my $ujszo;
             if($type eq 's'){
               $ujszo = strip_add_sfx($szo, $strip, $addtoword);
               push(@sfx_arr,$ujszo );
             } elsif($type  eq 'p'){
                if($comb eq 'y' or $comb eq 'Y'){
                  push( @pfx_arr, $addtoword);
                } else{
                  $ujszo = strip_add_pfx($szo, $strip, $addtoword);
                }
             }
             if($self->{sfx} and defined($ujszo)){print "$ujszo\n";}
         }
      }
    }
  }  # flarr
  if($self->{pfx}){
   if($self->{pfx}){
    foreach(@pfx_arr){
      my $pfx = $_;
      foreach(@sfx_arr){
        my $ujszo = $pfx.$_;
        if(defined($ujszo)){print "$ujszo\n";}
      }
    }
   }
  } # r_prefix
  @sfx_arr = ();
  @pfx_arr = ();


}

close(FH);


}


sub read_in_sfx{
   my($affixfile, $debug) = @_;

 my $new = 1;
 my (@sfx);
 my ($idx);
 $idx = 0;
 my $counter = 0;
 #my $debug = 2;
 my %shash;

open(FH, '<', $affixfile) or die $!;

 while(){
   if(index($_, "SFX ") == 0 or index($_, "PFX ") == 0){
     if($debug >=4){
       print $_;
     }
     if($new){
         my @fields = split( /\s{1,}/, $_);
         my @newarr;
        # print Dumper (\@fields);
         $sfx[$idx]{'count'}    = $fields[3];
         $sfx[$idx]{'id'}       = $fields[1];
         $sfx[$idx]{'comb'}     = $fields[2];
         $shash{$fields[1]} = $idx;
         if($fields[0] eq 'SFX'){
           $sfx[$idx]{'type'}     = 's';
         } else{
           $sfx[$idx]{'type'}     = 'p';
          }
         $sfx[$idx]{'elements'} = \@newarr;
         $new = 0;
      } else{
        my @fields = split( /\s{1,}/, $_);
        my $r = $sfx[$idx]{'elements'};
        my @newarr = @$r;
        $newarr[$counter]{'strip'}         = $fields[2];
        #
        # strip /.. from prefix
        #
        my @tmparr = split(/\//, $fields[3]);
        $newarr[$counter]{'add_to_word'}   = $tmparr[0];
        $newarr[$counter]{'condition'}     = read_cond($fields[4], $debug);
        $sfx[$idx]{'elements'} = \@newarr;
         ++ $counter;
        if($counter eq $sfx[$idx]{'count'}){
            $new = 1;
            $counter = 0;
            ++$idx;
         }

     }
   }
 }

 close(FH);

 return (\@sfx, \%shash);
}


sub read_cond{
   my($condition, $debug) = @_;

   my @carr;

   my $in_loop = 0;
   my @condarr = split(//, $condition);
   my ($tcarr);
   foreach (@condarr){
      if ($_  eq '['){
         if(!$in_loop){
           $in_loop = 1;
          } else {
            print "error1 in condition $condition\n";
          }
      }
      elsif($_ eq ']'){
        if($in_loop) {
          push(@carr, $tcarr);
          $in_loop = 0;
          $tcarr = '';
        }else {
            print "error2 in condition $condition\n";
        }
      }else {
        if($in_loop){
          $tcarr .= $_;
        }else{
           push(@carr, $_);
        }
      }

   }
   if($debug >=4){
      my $condarrsize =  @carr;
      my  $i;
      print "carr: $condarrsize\n";
      for ($i = 0; $i < $condarrsize; $i++){
        print "$i $carr[$i]\n";
      }
   }
   return \@carr;

}

sub met_cond{
   my($szo, $condref, $type, $debug) = @_;

   my @carr = @$condref;
   my $condarrsize =  @carr;
   if($debug >=5){
     print "condarrsize:$condarrsize\n";
   }

   if($carr[0] eq '.' and $condarrsize == 1 ){
     return 1;
   }elsif ($type eq 's'){
   my $lszo = length($szo);
   my $szoidx = $lszo - 1;
   my $i;
   for($i = $condarrsize -1; $i >=0; $i--){
     my $tobechecked = substr($szo, $szoidx, 1);
     if($debug >= 4){
        print "tbc:$tobechecked szdx:$szoidx ci:$carr[$i]\n";
     }
     if(length($carr[$i]) == 1){
        if ( $carr[$i] ne $tobechecked  and $carr[$i] ne '.'){
           if($debug >= 3){
             print "no match1\n";
           }
           return 0;
        }
    } else{
      my $j ;
      my $matched = 0;
      my $clen = length($carr[$i]);
      if(substr($carr[$i],0,1) eq '^'){ # inverted check
         for($j = 1; $j < $clen; $j++){
           if(substr($carr[$i],$j,1) eq $tobechecked){
             if($debug >= 3){
               print "no match2\n";
             }
             return 0;
           }
         }
         $matched = 1;
        } else{ # at least one matches
         for($j = 1; $j < $clen; $j++){
           if(substr($carr[$i],$j,1) eq  $tobechecked){
             $matched = 1;
             last;
           }
         }
        }
        if($matched eq 0){
           if($debug >= 3){
            print "no match3 i= $i szi: $szoidx tbc:$tobechecked\n";
           }
            return 0;
        }
     }
     --$szoidx;
    }

   } elsif($type eq 'p'){
   my $szoidx = 0;
   my $i;
   for($i = 0; $i <= $condarrsize -1; $i++){
     my $tobechecked = substr($szo, $szoidx, 1);
     if($debug >= 4){
        print "tbc:$tobechecked szdx:$szoidx ci:$carr[$i]\n";
     }
     if(length($carr[$i]) == 1){
        if ( $carr[$i] ne $tobechecked ){
           if($debug >= 3){
             print "no match1\n";
           }
           return 0;
        }
    } else{
      my $j ;
      my $matched = 0;
      my $clen = length($carr[$i]);
      if(substr($carr[$i],0,1) eq '^'){ # inverted check
         for($j = 1; $j < $clen; $j++){
           if(substr($carr[$i],$j,1) eq $tobechecked){
             if($debug >= 3){
               print "no match2\n";
             }
             return 0;
           }
         }
         $matched = 1;
        } else{ # at least one matches
         for($j = 1; $j < $clen; $j++){
           if(substr($carr[$i],$j,1) eq  $tobechecked){
             $matched = 1;
             last;
           }
         }
        }
        if($matched eq 0){
           if($debug >= 3){
            print "no match3 i= $i szi: $szoidx tbc:$tobechecked\n";
           }
            return 0;
        }
     }
     ++$szoidx;
    }

   }
  return 1;

}
sub strip_add_sfx{
  my($szo, $strip, $atw) = @_;
  if($strip ne '0'){
    $szo =  substr($szo, 0, (length($szo)-length($strip)));
  }
  return $szo.$atw;

}
sub strip_add_pfx{
  my($szo, $strip, $atw) = @_;
  if($strip ne '0'){
    $szo =  substr($szo, 0, (length($szo)-length($strip)));
  }
  return $atw.$szo;

}

1;

__END__