File Coverage

blib/lib/Regexp/Ethiopic.pm

Criterion	Covered	Total	%
statement	86	130	66.1
branch	22	52	42.3
condition	6	15	40.0
subroutine	11	16	68.7
pod	4	8	50.0
total	129	221	58.3

package Regexp::Ethiopic;
use base qw(Exporter);

use utf8;
BEGIN
{
use strict;
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS %EthiopicClasses
	                $ግዕዝ $ካዕብ $ሣልስ $ራብዕ $ኃምስ $ሳድስ $ሳብዕ
                	$ዘመደ_ግዕዝ $ዘመደ_ካዕብ $ዘመደ_ሣልስ $ዘመደ_ራብዕ $ዘመደ_ኃምስ);

	$VERSION = "0.15";

	@EXPORT_OK = qw(%EthiopicClasses &getForm &setForm &subForm &formatForms
	                $ግዕዝ $ካዕብ $ሣልስ $ራብዕ $ኃምስ $ሳድስ $ሳብዕ
                	$ዘመደ_ግዕዝ $ዘመደ_ካዕብ $ዘመደ_ሣልስ $ዘመደ_ራብዕ $ዘመደ_ኃምስ
	);
	%EXPORT_TAGS = ( forms => [qw(
	                 $ግዕዝ $ካዕብ $ሣልስ $ራብዕ $ኃምስ $ሳድስ $ሳብዕ
	                 $ዘመደ_ግዕዝ $ዘመደ_ካዕብ $ዘመደ_ሣልስ $ዘመደ_ራብዕ $ዘመደ_ኃምስ)],
			 utils => [qw(&getForm &setForm &subForm &formatForms &isFamilyOf)]
	);


%EthiopicClasses =(
	1	=> "ሀለሐመሠረሰሸቀቐበቨተቸኀነኘአከኸወዐዘዠየደዸጀገጘጠጨጰጸፀፈፐ",
	2	=> "ሁሉሐሙሡሩሱሹቁቑቡቩቱቹኁኑኙኡኩኹዉዑዙዡዩዱዹጁጉጙጡጩጱጹፁፉፑ",
	3	=> "ሂሊሒሚሢሪሲሺቂቒቢቪቲቺኂኒኚኢኪኺዊዒዚዢዪዲዺጂጊጚጢጪጲጺፂፊፒ",
	4	=> "ሃላሓማሣራሳሻቃቓባቫታቻኃናኛኣካኻዋዓዛዣያዳዻጃጋጛጣጫጳጻፃፋፓ",
	5	=> "ሄሌሔሜሤሬሴሼቄቔቤቬቴቼኄኔኜኤኬኼዌዔዜዤዬዴዼጄጌጜጤጬጴጼፄፌፔ",
	6	=> "ህልሕምሥርስሽቅቕብቭትችኅንኝእክኽውዕዝዥይድዽጅግጝጥጭጵጽፅፍፕ",
	7	=> "ሆሎሖሞሦሮሶሾቆቖቦቮቶቾኆኖኞኦኮኾዎዖዞዦዮዶዾጆጎጞጦጮጶጾፆፎፖ",
	8	=> "ቈቘኈኰዀጐኧ",
	9	=> "ቍቝኍኵዅጕ",
	10	=> "ቊቚኊኲዂጒ",
	11	=> "ሗሏሟሧሯሷሿቋቛቧቯቷቿኋኗኟኳዃዟዧዷዿጇጓጧጯጷጿፏፗ",
	12	=> "ቌቜኌኴዄጔ",
	ሀ	=> "ሀ-ሆ",
	ለ	=> "ለ-ሏ",
	ሐ	=> "ሐ-ሗ",
	መ	=> "መ-ሟ",
	ሠ	=> "ሠ-ሧ",
	ረ	=> "ረ-ሯ",
	ሰ	=> "ሰ-ሷ",
	ሸ	=> "ሸ-ሿ",
	ቀ	=> "ቀ-ቆቈ-ቍ",
	ቐ	=> "ቐ-ቖቘ-ቝ",
	በ	=> "በ-ቧ",
	ቨ	=> "ቨ-ቯ",
	ተ	=> "ተ-ቷ",
	ቸ	=> "ቸ-ቿ",
	ኀ	=> "ኀ-ኆኈ-ኍ",
	ነ	=> "ነ-ኗ",
	ኘ	=> "ኘ-ኟ",
	አ	=> "አ-ኧ",
	ከ	=> "ከ-ኮኰኲ-ኵ",
	ኸ	=> "ኸ-ኾዀ-ዅ",
	ወ	=> "ወ-ዎ",
	ዐ	=> "ዐ-ዖ",
	ዘ	=> "ዘ-ዟ",
	ዠ	=> "ዠ-ዧ",
	የ	=> "የ-ዮ",
	ደ	=> "ደ-ዷ",
	ዸ	=> "ዸ-ዿ",
	ጀ	=> "ጀ-ጇ",
	ገ	=> "ገ-ጎጐ-ጕ",
	ጘ	=> "ጘ-ጞ",
	ጠ	=> "ጠ-ጧ",
	ጨ	=> "ጨ-ጯ",
	ጰ	=> "ጰ-ጷ",
	ጸ	=> "ጸ-ጿ",
	ፀ	=> "ፀ-ፆ",
	ፈ	=> "ፈ-ፏ",
	ፐ	=> "ፐ-ፗ",
	አኃዝ	=> "፩-፼"
);

$EthiopicClasses{'ግዕዝ'}
	= $EthiopicClasses{geez}
	= $EthiopicClasses{1}
	;
$EthiopicClasses{'ካዕብ'}
	= $EthiopicClasses{kaib}
	= $EthiopicClasses{2}
	;
$EthiopicClasses{'ሣልስ'}
	= $EthiopicClasses{salis}
	= $EthiopicClasses{3}
	;
$EthiopicClasses{'ራብዕ'}
	= $EthiopicClasses{rabi}
	= $EthiopicClasses{4}
	;
$EthiopicClasses{'ኃምስ'}
	= $EthiopicClasses{hamis}
	= $EthiopicClasses{5}
	;
$EthiopicClasses{'ሳድስ'}
	= $EthiopicClasses{sadis}
	= $EthiopicClasses{6}
	;
$EthiopicClasses{'ሳብዕ'}
	= $EthiopicClasses{sabi}
	= $EthiopicClasses{7}
	;
$EthiopicClasses{'ዘመደ፡ግዕዝ'}
	= $EthiopicClasses{'zemede:geez'}
	= $EthiopicClasses{8}
	;
$EthiopicClasses{'ዘመደ፡ካዕብ'}
	= $EthiopicClasses{'zemede:kaib'}
	= $EthiopicClasses{9}
	;
$EthiopicClasses{'ዘመደ፡ሣልስ'}
	= $EthiopicClasses{'zemede:salis'}
	= $EthiopicClasses{10}
	;
$EthiopicClasses{'ዘመደ፡ራብዕ'}
	= $EthiopicClasses{'zemede:rabi'}
	= $EthiopicClasses{11}
	;
$EthiopicClasses{'ዘመደ፡ኃምስ'}
	= $EthiopicClasses{'zemede:hamis'}
	= $EthiopicClasses{12}
	;
$EthiopicClasses{'ahaz'}
	= $EthiopicClasses{'አኃዝ'}
	;

	($ግዕዝ, $ካዕብ, $ሣልስ, $ራብዕ, $ኃምስ, $ሳድስ, $ሳብዕ,
	$ዘመደ_ግዕዝ, $ዘመደ_ካዕብ, $ዘመደ_ሣልስ, $ዘመደ_ራብዕ, $ዘመደ_ኃምስ) = (1 .. 12);

}

sub import
{

	my @args = ( shift ); # package
	foreach (@_) {
		if ( /overload/o ) {
			use overload;
			overload::constant 'qr' => \&getRe;
		}
		elsif ( /:forms/o ) {
			Regexp::Ethiopic->export_to_level (1, $args[0], ':forms');  # this works too...
		}
		elsif ( /:utils/o ) {
			Regexp::Ethiopic->export_to_level (1, $args[0], ':utils');  # this works too...
		}
		else {
			push (@args, $_);
		}
	}
	if ($#args) {
		Regexp::Ethiopic->export_to_level (1, @args);  # this works too...
	}

}


sub getForm
{
my ($ሆሄ) = @_;

	my $form = ord($ሆሄ)%8 + 1;

	if ( $form == 8 || $ሆሄ =~ /[ቋቛኋኳዃጓ]/o ) {
		$form = 11;
	}
	elsif ( $ሆሄ =~ /[ቍቝኍኵዅጕ]/o ) {
		$form = 9;
	}
	elsif ( $ሆሄ =~ /[ቈቘኈኰዀጐቊቚኊኲዂጒቌቜኌኴዄጔ]/o ) {
		$form += 7;
	}

	$form;
}


sub setForm
{
my ($ሆሄ, $form) = @_;

	if ( $ሆሄ =~ /[ኈ-ኍቈ-ቍቘ-ቝኰ-ኵዀ-ዅጐ-ጕ]/o ) {
		$ሆሄ =~ s/[ኈ-ኍ]/ኅ/o;
		$ሆሄ =~ s/[ቈ-ቍ]/ቀ/o;
		$ሆሄ =~ s/[ቘ-ቝ]/ቐ/o;
		$ሆሄ =~ s/[ኰ-ኵ]/ከ/o;
		$ሆሄ =~ s/[ዀ-ዅ]/ኸ/o;
		$ሆሄ =~ s/[ጐ-ጕ]/ገ/o;
	}
	$form  = 4 if ( $ሆሄ =~ /[ቋቛኋኳዃጓ]/o );
	$form -= 7 if ( $form == 8 || $form == 10 || $form == 12 );
	$form  = 8 if ( $form == 11        );
	$form  = 6 if ( $form == 9         );

	chr ( ord($ሆሄ) - ord($ሆሄ)%8 + $form-1 );
}


sub subForm
{
my ($set, $get) = @_;

	#  e.g. s/([=#ሀ#=])/subForm($1, ሀ)/eg;
	setForm ( $set, getForm ( $get ) );
}


sub isFamilyOf
{
my ($a,$b) = @_;

	my $gez = setForm($a,1);
	my $re  = getRe( "[#$gez#]" );
	( $b =~ /$re/ );
}


sub formatForms
{
my ($format, $string) = @_;

	my @chars = split ( //, $string );

	if ( @chars != ($format =~ s/%/%/g) ) {
		$format =~ s/\p{Ethiopic}//g;
		warn ( "\"$string\" is of different length from $format." );
		return;
	}

	foreach (@chars) {
		$format =~ s/%(\d+)/setForm($_, $1)/e;
	}

	$format;
}


sub handleChars
{
my ($chars,$form) = @_;

	return ( $EthiopicClasses{$form} ) if ( $chars eq "all" );

my $re;

	$chars =~ s/(\w)(?=\w)/$1,/og;
	my @Chars = split ( /,/, $chars );
	foreach (@Chars) {
		if ( /(\w)-(\w)/o ) {
			my ($a,$b) = ($1,$2);
			foreach my $char (sort keys %EthiopicClasses) {
				next if ( length($char) > 1 );
				next unless ( (ord($a) <= ord($char)) && (ord($char) <= ord($b)) );
				if ( $form eq "all" ) {
					$re .= $EthiopicClasses{$char};
				}
				else {
					$EthiopicClasses{$form} =~ /([$EthiopicClasses{$char}])/;
					$re .= $1;
				}
			}
		}
		else {
			my $geez = setForm( $_, $ግዕዝ);
			if ( $form eq "all" ) {
				$re .= $EthiopicClasses{$geez};
			}
			else {
				$EthiopicClasses{$form} =~ /([$EthiopicClasses{$geez}])/;
				$re .= $1;
			}
		}
	}

$re;
}


sub setRange
{
my ($chars,$forms,$not) = @_;
$not ||= $_[3];

	my $re;

	if ( $forms eq "all" ) {
		$re = handleChars ( $chars, $forms );
	}
	else {
		my @Forms = split ( /,/, $forms);
		foreach (@Forms) {
			if ( /(\d)-(\d)/o ) {
				my ($a,$b) = ($1,$2);
				foreach my $form ($a..$b) {
					$re .= handleChars ( $chars, $form );
				}
			}
			else {
				my $form = $_;
				$re .= handleChars ( $chars, $form );
			}
		}
	}

	($re) ? ($not) ? "[$not$re]" : "[$re]" : "";
}


sub getRe
{
$_ = ($#_) ? $_[1] : $_[0];


	s/\[:(\p{Ethiopic}+|\w+):\]/($EthiopicClasses{$1}) ? "[$EthiopicClasses{$1}]" : "[:$1:]"/eog;
	s/\[#(\p{Ethiopic}|\d)#\]/($EthiopicClasses{$1}) ? "[$EthiopicClasses{$1}]" : ""/eog;
	s/\[#(\^)?([\d,-]+)#\]/setRange("all",$2,$1)/eog;
	s/\[#(\^)?([\p{Ethiopic},-]+)#\]/setRange($2,"all",$1)/eog;

	# print "  IN: $_\n";

	#
	# for some stupid reason the below doesn't work, so \w
	# is used in place of \p{Ethiopic}, dangerous...
	#
	# test 9 in examples/overload.pl will fail
	#
	# s/(\p{Ethiopic})\{#([\d,-]+)#\}/setRange($1,$2)/eog;
	s/(\w)\{#([\d,-]+)#\}/setRange($1,$2)/eog;

	s/\[(\^)?(\p{Ethiopic}+.*?)\]\{(\^)?#([\d,-]+)#\}/setRange($2,$4,$1,$3)/eog;

	# print "  OUT: $_\n";

	$_;
}



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


__END__