File Coverage

blib/lib/Convert/CEGH/Transliterate.pm

Criterion	Covered	Total	%
statement	68	86	79.0
branch	9	16	56.2
condition	3	6	50.0
subroutine	10	10	100.0
pod	0	3	0.0
total	90	121	74.3

package Convert::CEGH::Transliterate;
use warnings;
use strict;
use utf8;
use Regexp::Ethiopic qw(:forms setForm);

BEGIN
{
use base qw( Exporter );
use vars qw( $COPTIC @EXPORT_OK $VERSION );

	@EXPORT_OK = qw( transliterate );

	$VERSION = "0.07";

	$COPTIC = qr/[ϚCϢϤϦϨϬϮϪ]/;
}


sub fromIPA
{
my ($string, $script) = @_;

	$_ = $string;

	if ( $script =~ /^et/ ) {
		tr/ʤʧΘv/ztzb/;
		s/k'/q/g;
		s/p'/P/g;
		s/s'/S/g;
		s/t'/T/g;
		s/d'/D/g;
		tr/abgdhwzħTjklmnsʕfSqrʃtξDPp/አበገደሀወዘሐጠየከለመነሠዐፈጸቀረሰተኀፀጰፐ/;
	}
	elsif ( $script =~ /^he/ ) {
		tr/xfʤʧv/kpztb/;
		s/k'/q/g;
		s/s'/S/g;
		s/d'/d/g;
		s/p'/p/g;
		s/t'/t/g;
		s/ξ/h/g;
		tr/abgdhwzħΘjklmnsʕpSqrʃt/אבגדהוזחטיכלמנסעפצקרשת/;
		$_ = scalar reverse ( $_ );
	}
	elsif ( $script =~ /^el/ || $script =~ /^co/ ) {
		tr/ʤʧʕwv/ztabb/;
		s/ps/P/g;
		s/d'/d/g;
		s/p'/p/g;
		s/t'/t/g;
		s/ξ/h/g;
		tr/abgdazaΘaklmnxaprstafʧPa/ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΧΨΩ/;
		#
		# this is broken, the coptic extras are missing
		# and greek isn't mapping the extras, what is "w" is greek?
	}

	$_
}


sub toIPA
{

	$_ = $_[0];

	if ( /$COPTIC/ || /\p{Greek}/ ) {
		$_ = uc($_);
		tr/ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ/abgdazaΘaklmnKaprstafxPa/;
		if ( /$COPTIC/ ) {
			tr/ϚCϢϤϦϨϪϬ/ssʃfxhʤʧ/;
			s/Ϯ/t/g;  # really "ti" but we ignore the vowel.
		}
		s/[ϚϜ]/w/g;
		s/[ϘϞ]/k'/g;
		s/K/kh/g;
		s/P/ps/g;
	}
	if ( /\p{Ethiopic}/ ) {
		s/(.)/setForm($1,$ግዕዝ)/eg;
		tr/አበገደሀወዘሐጠየከለመነሠዐፈጸቀረሰተኀፀጰፐ/abgdhwzħTjklmnsʕfSqrʃtξDPp/;
		#
		# convert placeholder symbols to multiple symbols:
		#
		s/q/k'/g;
		s/P/p'/g;
		s/S/s'/g;
		s/T/t'/g;
		s/C/ʧ'/g;
		s/D/d'/g;
	}
	if ( /\p{Hebrew}/ ) {
		$_ = scalar reverse ( $_ );
		#
		# map finals to initials/medials:
		#
		s/ך/כ/g;
		s/ץ/צ/g;
		s/ף/פ/g;
		s/ם/מ/g;
		s/ן/נ/g;
		tr/אבגדהוזחטיכלמנסעפצקרשת/abgdhwzħΘjklmnsʕpSqrʃt/;
		#
		# convert placeholder symbols to multiple symbols:
		#
		s/q/k'/;
		s/S/s'/;
	}
	s/(.)a/$1/g;  # strip vowels except first

	$_;
}


sub transliterate
{
my ( $to, @strings ) = @_;

	my ( @trans ) = ();
	foreach ( @strings ) {
		push ( @trans, fromIPA ( toIPA ( $_ ), $to ) );
	}

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


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

__END__