File Coverage

blib/lib/Regexp/Cherokee.pm

Criterion	Covered	Total	%
statement	77	121	63.6
branch	18	42	42.8
condition	4	6	66.6
subroutine	11	16	68.7
pod	4	7	57.1
total	114	192	59.3

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

use utf8;
BEGIN
{
use strict;
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS %CherokeeClasses %CherokeeEquivalence $pseudoMatrix);

	$VERSION = "0.03";

	@EXPORT_OK = qw(%CherokeeClasses %CherokeeEquivalence &getForm &setForm &subForm &formatForms);
	%EXPORT_TAGS = ( utils => [qw(&getForm &setForm &subForm &formatForms)] );


%CherokeeClasses =(
	1	=> "ᎠᎦᎧᎭᎳᎹᎾᎿᏀᏆᏌᏍᏓᏔᏜᏝᏣᏩᏯ",
	2	=> "ᎡᎨᎮᎴᎺᏁᏇᏎᏕᏖᏞᏤᏪᏰ",
	3	=> "ᎢᎩᎯᎵᎻᏂᏈᏏᏗᏘᏟᏥᏫᏱ",
	4	=> "ᎣᎪᎰᎶᎼᏃᏉᏐᏙᏠᏦᏬᏲ",
	5	=> "ᎤᎫᎱᎷᎽᏄᏊᏑᏚᏡᏧᏭᏳ",
	6	=> "ᎥᎬᎲᎸᏅᏋᏒᏛᏢᏨᏮᏴ",
	Ꭰ	=> "Ꭰ-Ꭵ",
	Ꭶ	=> "Ꭶ-Ꭼ",
	Ꭽ	=> "Ꭽ-Ꮂ",
	Ꮃ	=> "Ꮃ-Ꮈ",
	Ꮉ	=> "Ꮉ-Ꮍ",
	Ꮎ	=> "Ꮎ-Ꮕ",
	Ꮖ	=> "Ꮖ-Ꮛ",
	Ꮜ	=> "Ꮜ-Ꮢ",
	Ꮣ	=> "Ꮣ-Ꮫ",
	Ꮬ	=> "Ꮬ-Ꮲ",
	Ꮳ	=> "Ꮳ-Ꮸ",
	Ꮹ	=> "Ꮹ-Ꮾ",
	Ꮿ	=> "Ꮿ-Ᏼ"
);

#
#  Cherokee Rules Orthography Equivalence
#
%CherokeeEquivalence =(
	Ꭶ	=> "ᎦᎧ",
	Ꮎ	=> "ᎾᎿᏀ",
	Ꮜ	=> "ᏌᏍ",
	Ꮣ	=> "ᏓᏔ",
	Ꮥ	=> "ᏕᏖ",
	Ꮧ	=> "ᏗᏘ",
	Ꮬ	=> "ᏜᏝ"
);
$CherokeeEquivalence{'Ꭷ'}
	= $CherokeeEquivalence{'Ꭶ'}
	;
$CherokeeEquivalence{'Ꮏ'}
	= $CherokeeEquivalence{'Ꮐ'}
	= $CherokeeEquivalence{'Ꮎ'}
	;
$CherokeeEquivalence{'Ꮝ'}
	= $CherokeeEquivalence{'Ꮜ'}
	;
$CherokeeEquivalence{'Ꮤ'}
	= $CherokeeEquivalence{'Ꮣ'}
	;
$CherokeeEquivalence{'Ꮦ'}
	= $CherokeeEquivalence{'Ꮥ'}
	;
$CherokeeEquivalence{'Ꮨ'}
	= $CherokeeEquivalence{'Ꮧ'}
	;
$CherokeeEquivalence{'Ꮭ'}
	= $CherokeeEquivalence{'Ꮬ'}
	;

# use a long string as a pseudo matrix
# get index in pseudo matrix, then find in index+form combination position in matrix

# 6x13 matrix

# Form 1: "ᎠᎦᎭᎳᎹᎾᏆᏌᏓᏜᏣᏩᏯ",
# Form 2: "ᎡᎨᎮᎴᎺᏁᏇᏎᏕᏞᏤᏪᏰ",
# Form 3: "ᎢᎩᎯᎵᎻᏂᏈᏏᏗᏟᏥᏫᏱ",
# Form 4: "ᎣᎪᎰᎶᎼᏃᏉᏐᏙᏠᏦᏬᏲ",
# Form 5: "ᎤᎫᎱᎷᎽᏄᏊᏑᏚᏡᏧᏭᏳ",
# Form 6: "ᎥᎬᎲᎸXᏅᏋᏒᏛᏢᏨᏮᏴ",

$pseudoMatrix = "ᎠᎦᎭᎳᎹᎾᏆᏌᏓᏜᏣᏩᏯᎡᎨᎮᎴᎺᏁᏇᏎᏕᏞᏤᏪᏰᎢᎩᎯᎵᎻᏂᏈᏏᏗᏟᏥᏫᏱᎣᎪᎰᎶᎼᏃᏉᏐᏙᏠᏦᏬᏲᎤᎫᎱᎷᎽᏄᏊᏑᏚᏡᏧᏭᏳᎥᎬᎲᎸXᏅᏋᏒᏛᏢᏨᏮᏴ";

}

sub import
{

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

}


sub getForm
{
my ($letter) = @_;


	foreach my $form (1..6) {
		return $form if ( $CherokeeClasses{$form} =~ $letter );
	}
}


#
#  unfortunately the index function in Perl 5.8.0 is broken for some
#  Unicode sequences: http://rt.perl.org/rt2/Ticket/Display.html?id=22375
#
sub _index
{
my ( $haystack, $needle ) = @_;

	my $pos = my $found = 0;
	foreach (split (//, $haystack) ) {
		$found = 1 if ( /$needle/ );
		$pos++ unless ( $found );
	}

	$pos;
}


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


	$form--;
	#
	# simplify
	#
	$letter =~ s/Ꭷ/Ꭶ/;
	$letter =~ s/[ᎿᏀ]/Ꮎ/;
	$letter =~ s/Ꮝ/Ꮜ/;
	$letter =~ s/Ꮤ/Ꮣ/;
	$letter =~ s/Ꮦ/Ꮥ/;
	$letter =~ s/Ꮨ/Ꮧ/;
	$letter =~ s/Ꮭ/Ꮬ/;

	# print "letter = $letter / form = $form\n";
	my $index = _index ( $pseudoMatrix, $letter );
	# print "index = $index\n";

        my $offset = ( ($index%13) + $form*13 );
	substr ( $pseudoMatrix, $offset, 1 );

}


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

	setForm ( $set, getForm ( $get ) );
}


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

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

	if ( @chars != ($format =~ s/%/%/g) ) {
		$format =~ s/\p{Cherokee}//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 ( $CherokeeClasses{$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 %CherokeeClasses) {
				next if ( length($char) > 1 );
				next unless ( (ord($a) <= ord($char)) && (ord($char) <= ord($b)) );
				if ( $form eq "all" ) {
					$re .= $CherokeeClasses{$char};
				}
				else {
					$CherokeeClasses{$form} =~ /([$CherokeeClasses{$char}])/;
					$re .= $1;
				}
			}
		}
		else {
			if ( $form eq "all" ) {
				$re .= $CherokeeClasses{$_};
			}
			else {
				$CherokeeClasses{$form} =~ /([$CherokeeClasses{$_}])/;
				$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);
		#
		# next time, put @Chars loop on the outside and set
		# up character ranges with -
		#
		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{Cherokee})=\]/($CherokeeEquivalence{$1}) ? "[$CherokeeEquivalence{$1}]" : $1/eog;
	s/\[#(\p{Cherokee}|\d)#\]/($CherokeeClasses{$1}) ? "[$CherokeeClasses{$1}]" : ""/eog;
	s/\[#(\^)?([\d,-]+)#\]/setRange("all",$2,$1)/eog;
	s/\[#(\^)?([\p{Cherokee},-]+)#\]/setRange($2,"all",$1)/eog;

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

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

	$_;
}



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


__END__