File Coverage

blib/lib/Text/Metaphone/Amharic.pm

Criterion	Covered	Total	%
statement	88	132	66.6
branch	17	48	35.4
condition			n/a
subroutine	11	16	68.7
pod	0	9	0.0
total	116	205	56.5

package Text::Metaphone::Amharic;

# If either of these next two lines are inside
# the BEGIN block the package will break.
#
use utf8;
use Regexp::Ethiopic::Amharic qw(:forms overload setForm);

BEGIN
{
	use strict;
	use vars qw( $VERSION %IMExpected %IMError %plosives $GRANULARITY $STYLE );

	$VERSION = "0.11";

	%plosives = (
		ቅ => 'k',
		ጥ => 't',
		ጭ => 'ʧ',
		ጵ => 'p',
		ጽ => 's'
	);
	%IMExpected =(
		ስ => "s",
		ጽ => "s'",
		ቅ => "k'",
		ቕ => "q",
		ት => "t",
		ጥ => "t'",
		ች => "ʧ",
		ጭ => "ʧ",
		ን => "n",
		ኝ => "n",
		ክ => "k",
		ዝ => "z",
		ዥ => "ʒ",
		ጵ => "p'",
		ፕ => "p"
	);
	%IMError  =(
		ስ => "ጽ",
		ጽ => "ስ",
		ቅ => "ቕ",
		ቕ => "ቅ",
		ት => "ጥ",
		ጥ => "ት",
		ች => "ጭ",
		ጭ => "ች",
		ን => "ኝ",
		ኝ => "ን",
		ክ => "ኽ",
		ዝ => "ዥ",
		ዥ => "ዝ",
		ጵ => "ፕ",
		ፕ => "ጵ"
	);
	$GRANULARITY = "low";
	$STYLE       = "ethio";
}


sub import
{
my ( $pkg, %args ) = @_;

	$STYLE       = lc($args{style})        if ( $args{style}       );
	$GRANULARITY = lc($args{granularity})  if ( $args{granularity} );
}


sub new
{
my $class = shift;
my $self = { _style => $STYLE, _granularity => $GRANULARITY };

	my $blessing = bless ( $self, $class );

	%_ = @_;

	$self->{_style}        = lc($_{style})        if ( $_{style}     );
	$self->{_granularity}  = lc($_{granularity})  if ( $_{granularity} );

	$blessing;
}


sub _formatStyle
{
my ($self, $keys) = @_;

	if ( $self->{_style} eq "ipa" ) {
		foreach my $i ( 0..$#{$keys} ) {
			$keys->[$i] =~ s/([ቅጥጭጵጽ])/$plosives{$1}'/og;
			$keys->[$i] =~ tr/ህልምርስሽቕብትችንኝእክውይድዽጅዝዥግጝፍፕ/hlmrsʃqbtʧnɲakwjdɗʤzʒgɲfp/;
		}
	}
	elsif ( $self->{_style} eq "sera" ) {
		foreach my $i ( 0..$#{$keys} ) {
			$keys->[$i] =~ tr/ህልምርስሽቅቕብትችንኝእክውይድዽጅዝዥግጝጥጭጵጽፍፕ/hlmrsxqQbtcnNakwydDjzZgGTCPSfp/;
		}
	}

}


sub metaphone
{
my $self = shift;

	$_ = $self->simplify($_[0]);
	my ($re, @keys) = $self->glyphs ( $_ );
	($re, @keys)    = $self->phono  ( $re, @keys );
	($re, @keys)    = $self->im     ( $re, @keys );

	if ( @keys ) {
		push ( @keys, qr/$re/ );
	}

	$self->_formatStyle ( \@keys ) if ( $self->{_style} ne "ethio" );

	(wantarray) ? @keys : $keys[0];
}


sub simplify
{
my $self = shift;

	$_ = $_[0];

	#
	# strip out all but first vowel:
	#
	s/^[=#አ#=]/አ/o;
	s/[=#ሀ#=]/ሀ/og;

	s/(.)[=#አ#=]/$1/g;

	if ( $self->{_granularity} eq "low" ) {
		s/(.)[#ወ#]/$1/og;
		s/(.)[#የ#]/$1/og;
	}
	else {
		s/([#11#])/setForm($1,$ሳድስ)."ዋ"/eg;
	}
	s/[=#ሰ#=]/ሰ/og;
	s/[=#ጸ#=]/ጸ/og;
	s/[#ቨ#]/በ/og;

	#
	# now strip vowels, this simplies later code:
	#
	s/(\p{Ethiopic})/ ($1 eq 'ኘ') ? $1 : setForm($1,$ሳድስ)/eg;


	$_;
}


sub glyphs
{
my $self = shift;


	my @keys = ( $_[0] );
	my $re = $_[0];

	#
	#  Confusion with ዽ
	#
	if ( $keys[0] =~ /ዽ/ ) {
		$keys[2] = $keys[1] = $keys[0];
		$keys[0] =~ s/ዽ/ድ/o;    # caps problem
		                        # $keys[1] literal
		$keys[2] =~ s/ዽ/ጵ/o;    # mistaken glyph
		$re =~ s/ዽ/([ድዽጵ])/og;
	}
	#
	#  Confusion with ኘ
	#
	if ( $keys[0] =~ /ኘ/ ) {
		my (@newKeysA, @newKeysB);
		for (my $i=0; $i < @keys; $i++) {
			$newKeysA[$i] = $newKeysB[$i] = $keys[$i];  # copy old keys
			                             # $keys[$i] literal
			$newKeysA[$i] =~ s/ኘ/ን/o;    # caps problem
			$newKeysB[$i] =~ s/ኘ/ፕ/o;    # mistaken glyph
		}
		push (@keys,@newKeysA);  # add new keys to old keys
		push (@keys,@newKeysB);  # add new keys to old keys
		$re =~ s/ኘ/[ንኝፕ]/og;
	}

	($re, @keys);
}


sub phono
{
my ( $self, $re, @keys ) = @_;



	if ( $keys[0] =~ /ም[ብፍ]/ ) {
		my @newKeys;
		for (my $i=0; $i < @keys; $i++) {
			$newKeys[$i] = $keys[$i];   # copy old keys
			$newKeys[$i] =~ s/ምብ/ንብ/o;  # update old keys for primary mapping
			$newKeys[$i] =~ s/ምፍ/ንፍ/o;  # update old keys for primary mapping
		}
		push (@keys,@newKeys);  # add new keys to old keys
		$re =~ s/ምብ/[ምን]ብ/og;
		$re =~ s/ምፍ/[ምን]ፍ/og;
	}

	($re, @keys);
}


sub im
{
my ( $self, $re, @keys ) = @_;

	my $first = 1;
	#
	#  Handle IM problems
	#  try to keep least probable keys last:
	#
	$_ = $keys[0];                                       # bidi folding             # upper-to-lower
	my $keyboard = ( $self->{_granularity} eq "high" ) ? qr/([ስቅቕትችንኝክዝዥጥጭጽጵፕ])/ : qr/([ቕኝዥጥጭጽጵ])/ ;

	while ( /$keyboard/ ) {
		my $a = $1;
		my @newKeys;
		if ( $self->{_granularity} eq "low" ) {
			s/$a/$IMExpected{$a}/g;
		}
		else {
			s/$a/$IMExpected{$a}/;
		}

		for (my $i=0; $i < @keys; $i++) {
			$newKeys[$i] = $keys[$i];           # copy old keys
		}

		if ( $first ) {
			# update new keys for alternative
			$keys[0] =~ s/^$a/ሀ$a/ if ( $self->{_style} ne "ipa" );
			if ( $self->{_granularity} eq "low" ) {
				$newKeys[0] =~ s/$a/ሀ$IMError{$a}/g;
			}
			else {
				$newKeys[0] =~ s/$a/ሀ$IMError{$a}/;
			}
		}

		for (my $i=$first; $i < @newKeys; $i++) {
			# update new keys for alternative
			if ( $self->{_granularity} eq "low" ) {
				$newKeys[$i] =~ s/([^ሀ])$a/$1ሀ$IMError{$a}/g;
			}
			else {
				$newKeys[$i] =~ s/([^ሀ])$a/$1ሀ$IMError{$a}/;
			}
		}

		$first = 0;
		push (@keys,@newKeys);   # add new keys to old keys

		#
		# this still needs work:
		#
		# $re =~ s/$a(?!\w+?\])/[$a$IMError{$a}]/g;
		$re =~ s/(?
	}

	#
	# convert symbols that were missed in low granularity mode:
	#
	foreach my $i (0..$#keys) {
		$keys[$i] =~ s/ሀ//og;
		$keys[$i] =~ s/ኘ/ኝ/og;
	}

	($re, @keys);
}


sub reverse
{
my $self = shift;

	$_ = $_[0];

	if ( $self->{_style} eq "ipa" ) {
		s/([stʧkp])'/$plosives{$1}/g;
		tr/hlmrsʃqbtʧnɲakwjdɗʤzʒgɲfp/ህልምርስሽቕብትችንኝእክውይድዽጅዝዥግጝፍፕ/;
	}
	elsif ( $self->{_style} eq "sera" ) {
		tr/hlmrsxqQbtcnNakwydDjzZgTCPSGfp/ህልምርስሽቅቕብትችንኝእክውይድዽጅዝዥግጝጥጭጵጽፍፕ/;
	}

	$_;
}


sub style
{
my $self = shift;

	$self->{_style} = lc($_[0]) if (@_);

	$self->{_style};
}


sub granularity
{
my $self = shift;

	$self->{_granularity} = lc($_[0]) if (@_);

	$self->{_granularity};
}



#########################################################
# Do not change this, Do not put anything below this.
# File must return "true" value at termination
1;
##########################################################

__END__