File Coverage

blib/lib/Lingua/Spelling/Alternative.pm

Criterion	Covered	Total	%
statement	65	103	63.1
branch	13	46	28.2
condition	0	4	0.0
subroutine	7	9	77.7
pod	5	6	83.3
total	90	168	53.5

# Documentation and Copyright exist after __END__

package Lingua::Spelling::Alternative;
require 5.001;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use Exporter;
$VERSION = '0.02';
@ISA = ('Exporter');

#@EXPORT = qw();
@EXPORT_OK = qw(
	&alternatives
	);

my $debug=0;

#
# make new instance of language, get args
#
sub new {
	my $class = shift;
	my $self = {};
	bless($self, $class);
	$self->{ARGS} = {@_};
	$debug = $self->{ARGS}->{DEBUG};
	@{$self->{affix_regexp}} = ();
	@{$self->{affix_add}} = ();
	@{$self->{affix_sub}} = ();
	$self ? return $self : return undef;
}


#
# load affix file in internal structures
#

sub load_affix {
	my $self = shift;
	my $filename = shift;

	my $suffixes=0;

	my ($regexp,$add,$sub);

	print STDERR "reading affix file $filename\n" if ($debug);

	open (A,$filename) || die "Can't open affix file $filename: $!";
	while() {
		chomp;
		next if (/^#|^[\s\t\n\r]*$/);

		if (/^suffixes/i) {
			$suffixes++;
			next;
		}

		next if (! $suffixes);

		if (/^flag[\s\t]+\*{0,1}(.):/i) {
			undef $regexp;
			undef $add;
			undef $sub;
			next;
		}

		if (/^[\s\t]*([^>#]+)>[\s\t]+-([^\,\s\t]+),([^\s\t]+)/) {
			$regexp = $1;
			$add = $2;
			$sub = $3 if ($3 ne "-");
		} elsif (/^[\s\t]*([^>#]+)>[\s\t]+([^\s\t\#]+)/) {
			$regexp = $1;
			$sub = $2;
		}

		sub nuke_s {
			my $tmp = $_[0];
			return if (!$tmp);
		#	$tmp=~s/^\s+//g;
		#	$tmp=~s/\s+$//g;
			$tmp=~s/\s+//g;
			return $tmp;
		}

		push @{$self->{affix_regexp}},nuke_s($regexp);
		push @{$self->{affix_add}},nuke_s($add);
		push @{$self->{affix_sub}},nuke_s($sub);
	}
	return 1;
}

#
# function for reading raw findaffix output
#

sub load_findaffix {
	my $self = shift;
	my $filename = shift;

	print STDERR "reading findaffix output $filename\n" if ($debug);

	open (A,$filename) || die "Can't open findaffix output $filename: $!";
	while() {
		chomp;
		my @line=split(m;/;,$_,4);
		if ($#line > 2) {
			push @{$self->{affix_regexp}},'.';
			push @{$self->{affix_sub}},$line[0];
			push @{$self->{affix_add}},$line[1];
		}
	}
	return 1;
}

#
# function which returns original word and all alternatives
#

sub alternatives {
	my $self = shift;
	my @out;
	foreach my $word (@_) {
		push @out,$word;		# save original word
		next if (length($word) < 3);	# cludge: preskoci kratke
		for(my $i=0; $i<=$#{$self->{affix_regexp}}; $i++) {
			my $regexp = $self->{affix_regexp}[$i];
			my $add = $self->{affix_add}[$i];
			my $sub = $self->{affix_sub}[$i];
			print STDERR "r:'$regexp'\t-'",$sub||'',"'\t+'",$add||'',"'\n" if ($debug);
			next if length($word) < length($sub);
			my $tmp_word = $word;
			if ($sub) {
				next if ($word !~ m/$sub$/i);
				if ($add) {
					$tmp_word =~ s/$sub$/$add/i;
				} else {
					$tmp_word =~ s/$sub$//i;
				}
			} else {
				$tmp_word = $word.$add;
			}
			print STDERR "\t ?:$tmp_word\n" if ($debug);
			if ($tmp_word =~ m/$regexp/ix) {
#				print "$word -> $tmp_word\t-$sub, +$add, regexp: $regexp\n";
				push @out,lc($tmp_word);
			}
		}
	}
	return @out;
}

#
# function which return minimal word of all alternatives
#

sub minimal {
	my $self = shift;
	my @out;
	foreach my $word (@_) {
		my @alt = $self->alternatives($word);
		my $minimal = shift @alt;
		foreach (@alt) {
			$minimal=$_ if (length($_) < length($minimal));
		}
		push @out,$minimal;
	}
	return @out;
}

###############################################################################
1;
__END__