File Coverage

blib/lib/MetaTrans/SeznamCz.pm

Criterion	Covered	Total	%
statement	18	66	27.2
branch	0	10	0.0
condition			n/a
subroutine	6	12	50.0
pod	3	3	100.0
total	27	91	29.6

=head1 NAME

MetaTrans::SeznamCz - MetaTrans plug-in for L

=cut

package MetaTrans::SeznamCz;

use strict;
use warnings;
use vars qw($VERSION @ISA);
use MetaTrans::Base;

use HTTP::Request;
use URI::Escape;

$VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d", @r };
@ISA     = qw(MetaTrans::Base);

=head1 CONSTRUCTOR METHODS

=over 4

=item MetaTrans::SeznamCz->new(%options)

This method constructs a new MetaTrans::SeznamCz object and returns it. All
C<%options> are passed to C<< MetaTrans::Base->new >>. The method also sets
supported translation directions and the C attribute.

=back

=cut

sub new
{
    my $class   = shift;
    my %options = @_;

    $options{host_server} = "slovnik.seznam.cz"
        unless (defined $options{host_server});

    my $self = new MetaTrans::Base(%options);
    $self = bless $self, $class;

    $self->set_languages("cze", "eng", "ger", "fre", "spa", "ita", "rus");

    $self->set_dir_1_to_all("cze");
    $self->set_dir_all_to_1("cze");

    return $self;
}

=head1 METHODS

Methods are inherited from C. Following methods are overriden:

=cut

=over 4

=item $plugin->create_request($expression, $src_lang_code, $dest_lang_code)

Create and return a C object to be used for retrieving
translation of the C<$expression> from C<$src_lang_code> language to
C<$dest_lang_code> language.

=cut

sub create_request
{
    my $self           = shift;
    my $expression     = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    my %table = (
        cze => "cz",
        eng => "en",
        ger => "de",
        fre => "fr",
        spa => "es",
        ita => "it",
        rus => "ru",
    );

    my $query =
        'http://slovnik.seznam.cz/?' .
        "q=" . uri_escape($expression) .
        "&lang=" . $table{$src_lang_code} . "_" . $table{$dest_lang_code};
    my $request = HTTP::Request->new(GET => $query);

    return $request;
}

=item $plugin->process_response($contents, $src_lang_code, $dest_lang_code)

Process the server response contents. Return the result of the translation in
an array of following form:

    (expression_1, translation_1, expression_2, translation_2, ...)

=back

=cut

sub process_response
{
    my $self           = shift;
    my $contents       = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    my @result;
    while ($contents =~ m|

        \s*

        \s*
        (.*?)
        \s*

        \s*

        (.*?)

        \s*

    |gsix)
    {
        my $expr  = _get_expr($1);
        my @trans = _get_trans($2);

        $expr = _normalize_german($expr)
            if $src_lang_code eq 'ger';

        foreach my $trans (@trans) {

            $trans = _normalize_german($trans)
                if $dest_lang_code eq 'ger';

            push @result, ($expr, $trans);
        }
    }

    return @result;
}

sub _get_expr
{
    my $string = shift;
    $string =~ s/]+>//g;
    $string =~ s/]+"><\/a>//g;
    if ($string =~ m/]+">(.*?)<\/a>/)
    {
        return $1;
    }
    else
    {
        return '';
    }
}

sub _get_trans
{
    my $string = shift;
    $string =~ s///g;
    $string =~ s/]+>//g;
    $string =~ s/]+"><\/a>//g;
    $string =~ s/\s{2,}/ /g;
    my @result;
    while ($string =~ m/]+">(.*?)<\/a>/gimx)
    {
        push @result, $1;
    }
    return @result;
}

# normalize german article: Hund, r -> Hund; r
sub _normalize_german
{
    my $expr = shift;

    # normalize german article: Hund (der) -> Hund; r
    $expr = $1 . "; " . substr($2, 2, 1)
        if $expr =~ m/^(.*?),\s+(der|die|das)$/;

    return $expr;
}

1;

__END__