File Coverage

blib/lib/Lingua/EO/Orthography.pm

Criterion	Covered	Total	%
statement	84	84	100.0
branch	14	14	100.0
condition	3	3	100.0
subroutine	26	26	100.0
pod	7	7	100.0
total	134	134	100.0

package Lingua::EO::Orthography;


# ****************************************************************
# perl dependency
# ****************************************************************

use 5.008_001;


# ****************************************************************
# pragma(s)
# ****************************************************************

use strict;
use warnings;
use utf8;


# ****************************************************************
# general depencency(-ies)
# ****************************************************************

use Carp qw(confess);
use Data::Util qw(:check neat);
use List::MoreUtils qw(any apply uniq);
use Memoize qw(memoize);
use Regexp::Assemble;
use Try::Tiny;


# ****************************************************************
# version
# ****************************************************************

our $VERSION = "0.04";


# ****************************************************************
# constructor
# ****************************************************************

sub new {
    my ($class, %init_arg) = @_;

    my $self = bless {}, $class;

    $self->sources(
          exists $init_arg{sources} ? $init_arg{sources}
        :                             ':all'
    );
    $self->target(
          exists $init_arg{target}  ? $init_arg{target}
        :                             'orthography'
    );

    return $self;
}


# ****************************************************************
# accessor(s) for attribute(s)
# ****************************************************************

sub sources {
    my ($self, $source_notation_candidates_ref) = @_;

    if (scalar @_ > 1) {    # $self->sources(undef) comes here and dies
        if (
            defined $source_notation_candidates_ref &&
            $source_notation_candidates_ref eq ':all'
        ) {
            $self->{sources} = [
                grep {
                    $_ ne 'orthography';
                } keys %{ $self->_notation }
            ];
        }
        else {
            try {
                $self->_check_source_notations($source_notation_candidates_ref);
            }
            catch {
                confess "Could not set source notations because: " . $_;
            };
            $self->{sources} = [ uniq @$source_notation_candidates_ref ];
        }
    }

    return $self->{sources};
}

sub target {
    my ($self, $target_notation_candidate) = @_;

    if (scalar @_ > 1) {    # $self->target(undef) comes here and dies
        try {
            $self->_check_notations($target_notation_candidate);
        }
        catch {
            confess "Could not set a target notation because: " . $_;
        };
        $self->{target} = $target_notation_candidate;
    }

    return $self->{target};
}


# ****************************************************************
# utility(-ies) for attribute(s)
# ****************************************************************

sub all_sources {
    my $self = shift;

    return @{ $self->{sources} };
}

sub add_sources {
    my ($self, @adding_notations) = @_;

    try {
        $self->_check_notations(@adding_notations);
    }
    catch {
        confess "Could not add source notations because: " . $_;
    };
    @{ $self->{sources} } = uniq $self->all_sources, @adding_notations;

    return $self->{sources};
}

sub remove_sources {
    my ($self, @removing_notations) = @_;

    try {
        $self->_check_notations(@removing_notations);

        # Note: I dare do not use List::Compare to get complement notations
        my %removing_notation;
        @removing_notation{ @removing_notations } = ();
        $self->{sources} = [
            grep {
                ! exists $removing_notation{$_};
            } $self->all_sources
        ];

        die 'Converter must maintain at least one source notation'
            unless @{ $self->{sources} };
    }
    catch {
        confess "Could not remove source notations because: " . $_;
    };

    return $self->{sources};
}


# ****************************************************************
# converter(s)
# ****************************************************************

sub convert {
    my ($self, $string) = @_;

    confess sprintf 'Could not convert string because '
                  . 'string (%s) must be a primitive value',
                neat($string)
        unless is_value($string);

    my $source_pattern   = $self->_source_pattern( @{ $self->sources } );
    my $target_character = $self->_target_character( $self->target );

    $string =~ s{
        ($source_pattern)
    }{$target_character->{$1}}xmsg;

    return $string;
}


# ****************************************************************
# checker(s)
# ****************************************************************

sub _check_notations {
    my ($self, @notation_candidates) = @_;

    my $notation_ref = $self->_notation;

    map {
        die sprintf 'Notation (%s) must be a primitive value',
                    neat($_)
            unless is_value($_);

        die sprintf 'Notation (%s) does not enumerated',
                    neat($_)
            unless exists $notation_ref->{$_};
    } @notation_candidates;

    return;
}

sub _check_source_notations {
    my ($self, $source_notation_candidates_ref) = @_;

    confess 'Source notations must be an array reference'
        unless is_array_ref($source_notation_candidates_ref);
    confess 'Source notations must be a nonnull array reference'
        unless @$source_notation_candidates_ref;

    $self->_check_notations(@$source_notation_candidates_ref);

    return;
}


# ****************************************************************
# internal properties
# ****************************************************************

sub _notation {
    return {
        orthography => [(           # LATIN (CAPITAL|SMALL) LETTER ...
            "\x{108}", "\x{109}",   #   ... C WITH CIRCUMFLEX
            "\x{11C}", "\x{11D}",   #   ... G WITH CIRCUMFLEX
            "\x{124}", "\x{125}",   #   ... H WITH CIRCUMFLEX
            "\x{134}", "\x{135}",   #   ... J WITH CIRCUMFLEX
            "\x{15C}", "\x{15D}",   #   ... S WITH CIRCUMFLEX
            "\x{16C}", "\x{16D}",   #   ... U WITH BREVE
        )],
        zamenhof            => [qw(Ch ch Gh gh Hh hh Jh jh Sh sh U  u )],
        capital_zamenhof    => [qw(CH ch GH gh HH hh JH jh SH sh U  u )],
        postfix_h           => [qw(Ch ch Gh gh Hh hh Jh jh Sh sh Uw uw)],
        postfix_capital_h   => [qw(CH ch GH gh HH hh JH jh SH sh UW uw)],
        postfix_x           => [qw(Cx cx Gx gx Hx hx Jx jx Sx sx Ux ux)],
        postfix_capital_x   => [qw(CX cx GX gx HX hx JX jx SX sx UX ux)],
        postfix_caret       => [qw(C^ c^ G^ g^ H^ h^ J^ j^ S^ s^ U^ u^)],
        postfix_apostrophe  => [qw(C' c' G' g' H' h' J' j' S' s' U' u')],
        prefix_caret        => [qw(^C ^c ^G ^g ^H ^h ^J ^j ^S ^s ^U ^u)],
    };
}

sub _source_pattern {
    my ($self, @source_notations) = @_;

    my $regexp_assembler = Regexp::Assemble->new;
    my $notation_ref     = $self->_notation;

    SOURCE_NOTATION:
    foreach my $source_notation (@source_notations) {
        SOURCE_CHARACTER:
        foreach my $source_character (
            @{ $notation_ref->{ $source_notation } }
        ) {
            next SOURCE_CHARACTER
                if $source_character =~ m{ \A [Uu] \z }xms;
            ( my $escaped_source_character = $source_character )
                =~ s{ (?=[\^\*\+]) }{\\}xms;
            $regexp_assembler->add($escaped_source_character);
        }
    }

    return $regexp_assembler->re;
}

sub _target_character {
    my ($self, $target_notation) = @_;

    return ( $self->_converter_table )->{$target_notation};
}

# Returns table as {$target_notation}{'source_character'} => 'target_character'
sub _converter_table {
    my $self = shift;

    my $converter_table;
    my $source_notations_ref = $self->_notation;
    my $target_notation_ref  = { %$source_notations_ref };

    TARGET_NOTATION:
    while (
        my ($target_notation, $target_characters_ref)
            = each %$target_notation_ref
    ) {
        SOURCE_NOTATION:
        while (
            my ($source_notation, $source_characters_ref)
                = each %$source_notations_ref
        ) {
            next SOURCE_NOTATION
                if $source_notation eq $target_notation;

            SOURCE_CHARACTER:
            foreach my $index ( 0 .. $#{$source_characters_ref} ) {
                next SOURCE_CHARACTER
                    if $source_characters_ref->[$index]
                        =~ m{ \A [Uu] \z }xms;
                $converter_table->{ $target_notation }
                                  { $source_characters_ref->[$index] }
                    = $target_characters_ref->[$index];
            }
        }
    }

    return $converter_table;
}


# ****************************************************************
# memoization
# ****************************************************************

sub _memoize_methods {
    map {
        memoize $_
    } qw(
        _check_notations
        _check_source_notations
        _notation
        _source_pattern
        _target_character
        _converter_table
    );

    return;
}


# ****************************************************************
# compile-time process(es)
# ****************************************************************

__PACKAGE__->_memoize_methods;


# ****************************************************************
# return true
# ****************************************************************

1;
__END__