File Coverage

blib/lib/WWW/Translate/Apertium.pm

Criterion	Covered	Total	%
statement	50	107	46.7
branch	10	36	27.7
condition	4	9	44.4
subroutine	11	17	64.7
pod	6	6	100.0
total	81	175	46.2

package WWW::Translate::Apertium;

use strict;
use warnings;
use Carp qw(carp);
use LWP::UserAgent;
use URI::Escape;
use HTML::Entities;
use Encode;
use utf8;


our $VERSION = '0.16';


my %lang_pairs = (
                    'es-ca'          => 'Spanish -> Catalan', # Default
                    'ca-es'          => 'Catalan -> Spanish',
                    'es-gl'          => 'Spanish -> Galician',
                    'gl-es'          => 'Galician -> Spanish',
                    'es-pt'          => 'Spanish -> Portuguese',
                    'pt-es'          => 'Portuguese -> Spanish',
                    'ca-pt'          => 'Catalan -> Portuguese',
                    'pt-ca'          => 'Portuguese -> Catalan',
                    'gl-pt'          => 'Galician -> Portuguese',
                    'pt-gl'          => 'Portuguese -> Galician',
                    'es-pt_BR'       => 'Spanish -> Brazilian Portuguese',
                    'oc-ca'          => 'Occitan -> Catalan',
                    'ca-oc'          => 'Catalan -> Occitan',
                    'oc-es'          => 'Occitan -> Spanish',
                    'es-oc'          => 'Spanish -> Occitan',
                    'oc_aran-ca'     => 'Aranese -> Catalan',
                    'ca-oc_aran'     => 'Catalan -> Aranese',
                    'en-ca'          => 'English -> Catalan',
                    'ca-en'          => 'Catalan -> English',
                    'fr-ca'          => 'French -> Catalan',
                    'ca-fr'          => 'Catalan -> French',
                    'fr-es'          => 'French -> Spanish',
                    'es-fr'          => 'Spanish -> French',
                    'ca-eo'          => 'Catalan -> Esperanto',
                    'es-eo'          => 'Spanish -> Esperanto',
                    'en-eo'          => 'English -> Esperanto',
                    'eo-en'          => 'Esperanto -> English',
                    'ro-es'          => 'Romanian -> Spanish',
                    'es-en'          => 'Spanish -> English',
                    'en-es'          => 'English -> Spanish',
                    'cy-en'          => 'Welsh -> English',
                    'eu-es'          => 'Basque -> Spanish',
                    'en-gl'          => 'English -> Galician',
                    'gl-en'          => 'Galician -> English',
                    'br-fr'          => 'Breton -> French',
                    'nb-nn'          => 'Norwegian Bokmål -> Norwegian Nynorsk',
                    'nn-nb'          => 'Norwegian Nynorsk -> Norwegian Bokmål',
                    'sv-da'          => 'Swedish-Danish',
                    'es-ast'         => 'Spanish-Asturian',
                    'is-en'          => 'Icelandic-English',
                    'bg-mk'          => 'Bulgarian-Macedonian',
                    'mk-bg'          => 'Macedonian-Bulgarian',
                 );

my %output =     (
                    plain_text  => 'txtf',  # default
                    marked_text => 'txt',
                 );

my %defaults =   (
                    lang_pair     => 'ca-es',
                    output        => 'plain_text',
                    store_unknown => 0,
                 );


sub new {
    my $class = shift;

    # validate overrides
    my %overrides = @_;
    foreach (keys %overrides) {
        # check key; warn if illegal
        carp "Unknown parameter: $_\n" unless exists $defaults{$_};

        # check value; warn and delete if illegal
        if ($_ eq 'output' && !exists $output{$overrides{output}}) {
            carp _message('output', $overrides{output});
            delete $overrides{output};
        }
        if ($_ eq 'lang_pair' && !exists $lang_pairs{$overrides{lang_pair}}) {
            carp _message('lang_pair', $overrides{lang_pair});
            delete $overrides{lang_pair};
        }
    }

    # replace defaults with overrides
    my %args = (%defaults, %overrides);

    # remove invalid parameters
    my @fields = keys %defaults;
    my %this;
    @this{@fields} = @args{@fields};

    if ($this{store_unknown}) {
        $this{unknown} = ();
    }


    $this{agent} = LWP::UserAgent->new( agent => 'apertium2perl' );
    $this{agent}->env_proxy();
    $this{url} = 'http://xixona.dlsi.ua.es/webservice/ws.php';


    return bless(\%this, $class);
}


sub translate {
    my $self = shift;

    my $string;
    if (@_ > 0) {
        $string = shift;
    } else {
        carp "Nothing to translate\n";
        return '';
    }

    return '' if ($string eq '');

    $string = _fix_source($string);
    $string = uri_escape_utf8($string);

    my $browser = $self->{agent};


    my $source_lang = substr($self->{lang_pair}, 0, 2);
    my $target_lang = substr($self->{lang_pair}, 3, 2);

    my $url = "$self->{url}?mode=$self->{lang_pair}&format=txt&text=$string";

    if ($self->{output} eq 'marked_text') {
        $url .= "&mark=1";
    } else {
        $url .= "&mark=0";
    }

    my $response = $browser->get($url);


    unless ($response->is_success) {
        carp $response->status_line;
        return undef;
    }


    if (!defined $response) {
        carp "Didn't receive a translation from the Apertium server.\n" .
             "Please check the length of the source text.\n";
        return '';
    }

    my $translated = _fix_translated($response->{'_content'});

    $translated = decode_utf8($translated);
    $translated = decode_entities($translated);

    if ($self->{output} eq 'marked_text') {

        if ($self->{store_unknown}) {

            # store unknown words
            if ($translated =~ /(?:^|\W)\*/) {

                while ($translated =~ /(?:^|\W)\*(\w+?)\b/g) {
                    $self->{unknown}->{$source_lang}->{$1}++;
                }
            }
        }
    }

    return $translated;
}

sub from_into {
    my $self = shift;


    if (@_) {
        my $pair = shift;
        if (!exists $lang_pairs{$pair}) {
            carp _message('lang_pair', $pair);
            $self->{lang_pair} = $defaults{'lang_pair'};
        } else {
            $self->{lang_pair} = $pair;
        }
    } else {
        return $self->{lang_pair};
    }
}

sub output_format {
    my $self = shift;

    if (@_) {
        my $format = shift;
        $self->{output} = $format if exists $output{$format};
    } else {
        return $self->{output};
    }
}

sub get_unknown {
    my $self = shift;

    if (@_ && $self->{store_unknown}) {
        my $lang_code = shift;
        if ($lang_code =~ /^(?:br|ca|cy|en|eo|es|eu|fr|gl|is|nb|nn|oc|oc_aran|pt|ro|sv|bg|mk)$/) {
            return $self->{unknown}->{$lang_code};
        } else {
            carp "Invalid language code\n";
        }
    } else {
        carp "I'm not configured to store unknown words\n";
    }
}

sub get_pairs {
    my $self = shift;

    return %lang_pairs;
}

sub _message {
    my ($key, $value) = @_;

    my $string = "Invalid value for parameter $key, $value.\n" .
                 "Will use the default value instead.\n";

    return $string;
}

sub _fix_source {
    my ($string) = @_;

    # fix geminated l; replace . by chr(183) = hex B7
    $string =~ s/l\.l/l\xB7l/g;

    return $string;
}

sub _fix_translated {
    my ($string) = @_;

    # remove double spaces
    $string =~ s/(?<=\S)\s{2}(?=\S)/ /g;

    return $string;
}


1;

__END__