File Coverage

blib/lib/Lingua/TR/ASCII.pm

Criterion	Covered	Total	%
statement	85	85	100.0
branch	20	22	90.9
condition	13	17	76.4
subroutine	16	16	100.0
pod	2	2	100.0
total	136	142	95.7

package Lingua::TR::ASCII;
$Lingua::TR::ASCII::VERSION = '0.16';
use strict;
use warnings;
use utf8;
use base qw( Exporter );
use Lingua::TR::ASCII::Data;

our @EXPORT  = qw( ascii_to_turkish turkish_to_ascii );

sub ascii_to_turkish {
    my($str) = @_;
    return $str if ! $str;
    return __PACKAGE__->_new( $str )->_deasciify;
}

sub turkish_to_ascii {
    my($str, $encoding) = @_;
    require Text::Unidecode;
    use utf8;
    return Text::Unidecode::unidecode( $str );
}

sub _new {
    my($class, $input) = @_;
    my $self = {
        input   => $input,
        length  => length $input,
        turkish => $input,
    };
    bless $self, $class;
    return $self;
}

# Convert a string with ASCII-only letters into one with Turkish letters.
sub _deasciify {
    my($self) = @_;
    my $s     = \$self->{turkish};
    my @chars = split m{}xms, ${$s};

    for my $i ( 0 .. $#chars ) {
        my $c = $chars[$i];
        next if ! $self->_needs_correction( $c, $i );
        substr ${$s}, $i, 1, $TOGGLE_ACCENT->{ $c } || $c;
    }

    return ${$s};
}

# Determine if char at cursor needs correction.
sub _needs_correction {
    my($self, $ch, $point) = @_;
    my $tr = $ASCIIFY->{ $ch } || $ch;
    my $pl = $PATTERN->{ lc $tr };
    my $m  = $pl ? $self->_matches( $pl, $point || 0 ) : 0;

    return $tr eq 'I' ? ( $ch eq $tr ? ! $m :   $m )
                      : ( $ch eq $tr ?   $m : ! $m );
}

# Check if the pattern is in the pattern table.
sub _matches {
    my($self, $dlist, $point) = @_;
    my $str  = $self->_get_context( $point || 0 );
    my $rank = 2 * keys %{ $dlist };
    my $len  = length $str;
    my($start, $end);

    while ( $start++ <= CONTEXT_SIZE ) {
        $end = CONTEXT_SIZE;
        while ( ++$end <= $len ) {
            my $s = substr $str, $start, $end - $start;
            my $r = $dlist->{ $s } || next;
            $rank = $r if abs $r < abs $rank;
        }
    }

    return $rank > 0;
}

sub _get_context {
    my($self, $point, $size) = @_;
    $size ||= CONTEXT_SIZE;
    my($s, $i, $space, $index);

    my $morph = sub {
        my($next, $lookup) = @_;
        $index = $point;
        $space = 0;
        while ( $next->() ) {
            my $char = substr $self->{turkish}, $index, 1;
            my $x    = $lookup->{ $char };
            if ( $x ) {
                substr $s, abs $i, 1, $x;
                $space = 0;
                $i++;
                next;
            }
            next if $space;
            $space = 1;
            $i++;
        }
    };

    $s = q{ } x ( 1 + ( 2 * $size ) );
    $i = 1 + $size;
    substr $s, $size, 1, 'X';

    $morph->(
        sub { $i < length $s && ! $space && ++$index < $self->{length} },
        $DOWNCASE_ASCIIFY
    );

    $s = substr $s, 0, $i;
    $i = 0 - --$size;

    $morph->(
        sub { $i <= 0 && --$index >= 0 },
        $UPCASE_ACCENTS
    );

    return $s;
}

1;

__END__