MetaTrans::Base - Abstract base class for creating meta-translator plug-ins

    # This is not a working example. It serves for illustration only.
    # For a working one see MetaTrans::UltralinguaNet source code.

    package MetaTrans::MyPlugin;

    use MetaTrans::Base;
    use vars qw(@ISA);
    @ISA = qw(MetaTrans::Base);

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

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

        $options{host_server} = "www.some-online-translator.com"
            unless (defined $options{host_server});

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

        # supported translation directions:
        #   English <-> German
        #   English <-> French
        #   English <-> Spanish

        $self->set_languages('eng', 'ger', 'fre', 'spa');

        $self->set_dir_1_to_all('eng');
        $self->set_dir_all_to_1('eng');

        return $self;
    }

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

        # our-language-codes-to-server-language-codes conversion table
        my %table = (eng => 'eng', ger => 'deu', fre => 'fra', spa => 'esp');

        return new HTTP::Request('GET',
            'http://www.some-online-translator.com/translate.cgi?' .
            'expr=' . uri_escape($expression) . '&' .
            'src='  . $table{$src_lang_code}  . '&' .
            'dst='  . $table{$dest_lang_code}
        );
    }

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

        # we don't care about these here, but 
        # in some cases we might need to care
        my $src_lang_code  = shift;
        my $dest_lang_code = shift;

        my @result;
        while ($contents =~ m|
            <td class="expr">([^<]*)</td>
            <td class="trns">([^<]*)</td>
        |gsix)
        {
            my $expression  = $1;
            my $translation = $2;

            # add some $expression and $translation normalization code here

            push @result, ($expression, $translation);
        }

        return @result;
    }

    1;

    English -> French
    English -> German
    French  -> Spanish

package MetaTrans::Base;

use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS %ENV);
use Exporter;
use MetaTrans::Languages qw(get_lang_by_code is_known_lang);

use Carp;
use Encode;
use Getopt::Long;
use HTML::Entities;
use LWP::UserAgent;
use HTTP::Response;

$VERSION     = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%02d", @r };
@ISA         = qw(Exporter);
@EXPORT_OK   = qw(is_exact_match is_match_at_start is_match_expr is_match_words
    convert_to_utf8 M_EXACT M_START M_EXPR M_WORDS M_ALL);
%EXPORT_TAGS = (
    match_consts => [qw(M_EXACT M_START M_EXPR M_WORDS M_ALL)],
    match_funcs  => [qw(is_exact_match is_match_at_start is_match_expr
        is_match_words)],
);


# Expression matching types
use constant M_EXACT => 1; # exact match
use constant M_START => 2; # match at start
use constant M_EXPR  => 3; # match expression
use constant M_WORDS => 4; # match words
use constant M_ALL   => 5; # match anything to anything

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

    my $self = bless {}, $class;

    my %defaults = (
        host_server     => 'unknown.server',
        script_name     => undef,
        timeout         => 5,
        matching        => M_START,
        match_at_bounds => 1,
    );

    foreach my $attr (keys %defaults)
    {
        $self->{$attr} = $options{$attr} || $defaults{$attr};
    }

    return $self;
}

sub host_server     { shift->_elem('host_server',     @_); }
sub script_name     { shift->_elem('script_name',     @_); }
sub timeout         { shift->_elem('timeout',         @_); }
sub match_at_bounds { shift->_elem('match_at_bounds', @_); }

sub matching
{
    my $self = shift;
    my $type = shift;

    my %ok = (M_EXACT, 1, M_START, 1, M_EXPR, 1, M_WORDS, 1, M_ALL, 1);
    my $old = $self->{matching};

    if (defined $type)
    {
        exists $ok{$type} ?
            $self->{matching} = $type :
            carp "invalid matching type: '$type'";
    }

    return $old;
}

sub default_dir
{
    my $self           = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    my @old_direction;
    if (defined @{$self->{direction}} &&
        $self->is_supported_dir(@{$self->{direction}}))
    {
        @old_direction = @{$self->{direction}};
    }
    else
    {
        # return `the first' supported translation direction
        OUTER: foreach my $src_lang_code (@{$self->{language_keys}})
        {
            foreach my $dest_lang_code (@{$self->{language_keys}})
            {
                if ($self->is_supported_dir($src_lang_code, $dest_lang_code))
                {
                    @old_direction = ($src_lang_code, $dest_lang_code);
                    last OUTER;
                }
            }
        }
    }

    return @old_direction
        unless defined $src_lang_code && defined $dest_lang_code;

    if ($self->is_supported_dir($src_lang_code, $dest_lang_code))
    {
        carp "not supported direction: '${src_lang_code}2${dest_lang_code}'";
        return @old_direction;
    }

    @{$self->{direction}} = ($src_lang_code, $dest_lang_code);
    return @old_direction;
}

sub set_languages
{
    my $self           = shift;
    my @language_codes = @_;

    foreach (@language_codes)
    {
        unless (is_known_lang($_))
        {
            carp "unknown language code: '$_', ignoring it";
            next;
        }

        ${$self->{languages}}{$_} = get_lang_by_code($_);
        push @{$self->{language_keys}}, $_; # to keep ordering
    }
}

sub set_dir_1_to_1
{
    my $self           = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    unless (${$self->{languages}}{$src_lang_code})
    {
        carp "language '$src_lang_code' not supported, " .
            "not setting '${src_lang_code}2${dest_lang_code}'";
        return 0;
    }

    unless (${$self->{languages}}{$dest_lang_code})
    {
        carp "language '$dest_lang_code' not supported, " .
            "not setting '${src_lang_code}2${dest_lang_code}'";
        return 0;
    }

    ${$self->{directions}}{$src_lang_code . "2" . $dest_lang_code} = 1;
    return 1;
}

sub unset_dir_1_to_1
{
    my $self           = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    unless (${$self->{languages}}{$src_lang_code})
    {
        carp "language '$src_lang_code' not supported, " .
            "not unsetting '${src_lang_code}2${dest_lang_code}'";
        return 0;
    }

    unless (${$self->{languages}}{$dest_lang_code})
    {
        carp "language '$dest_lang_code' not supported, " .
            "not unsetting '${src_lang_code}2${dest_lang_code}'";
        return 0;
    }

    undef ${$self->{directions}}{$src_lang_code . "2" . $dest_lang_code};
    return 1;
}

sub set_dir_1_to_spec
{
    my $self             = shift;
    my $src_lang_code    = shift;
    my @dest_lang_codes  = @_;
    my $set              = 0;

    unless (${$self->{languages}}{$src_lang_code})
    {
        carp "language '$src_lang_code' not supported";
        return $set;
    }

    foreach my $dest_lang_code (@dest_lang_codes)
    {
        next if $dest_lang_code eq $src_lang_code;
        $set += $self->set_dir_1_to_1($src_lang_code, $dest_lang_code);
    }

    return $set;
}

sub set_dir_1_to_all
{
    my $self          = shift;
    my $src_lang_code = shift;

    return $self->set_dir_1_to_spec($src_lang_code, @{$self->{language_keys}});
}

sub set_dir_spec_to_1
{
    my $self           = shift;
    my $dest_lang_code = shift;
    my @src_lang_codes = @_;
    my $set            = 0;

    unless (${$self->{languages}}{$dest_lang_code})
    {
        carp "language '$dest_lang_code' not supported";
        return $set;
    }

    foreach my $src_lang_code (@src_lang_codes)
    {
        next if $src_lang_code eq $dest_lang_code;
        $set += $self->set_dir_1_to_1($src_lang_code, $dest_lang_code);
    }

    return $set;
}

sub set_dir_all_to_1
{
    my $self           = shift;
    my $dest_lang_code = shift;

    return $self->set_dir_spec_to_1($dest_lang_code,
        @{$self->{language_keys}});
}

sub is_supported_dir
{
    my $self           = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;

    return ${$self->{directions}}{$src_lang_code . "2" . $dest_lang_code};
}

sub get_all_src_lang_codes
{
    my $self = shift;
    my @result;

    OUTER: foreach my $src_lang_code (@{$self->{language_keys}})
    {
        foreach my $dest_lang_code (@{$self->{language_keys}})
        {
            if ($self->is_supported_dir($src_lang_code, $dest_lang_code))
            {
                push @result, $src_lang_code;
                next OUTER;
            }
        }
    }

    return @result;
}

sub get_dest_lang_codes_for_src_lang_code
{
    my $self          = shift;
    my $src_lang_code = shift;
    my @result;

    foreach my $dest_lang_code (@{$self->{language_keys}})
    {
        push @result, $dest_lang_code
            if $self->is_supported_dir($src_lang_code, $dest_lang_code);
    }

    return @result;
}

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

    unless (scalar(keys %{$self->{directions}}) > 0)
    {
        carp "no supported directions defined";
        return 'error';
    }

    ($src_lang_code, $dest_lang_code) = $self->default_dir
        unless (defined $src_lang_code && defined $dest_lang_code);

    unless ($self->is_supported_dir($src_lang_code, $dest_lang_code))
    {
        carp "not supported direction: '${src_lang_code}2${dest_lang_code}'";
        return 'error';
    }

    my $ua = new LWP::UserAgent;
    $ua->cookie_jar({ file => "$ENV{HOME}/.metatrans.cookies.txt" });
    $ua->timeout($self->{timeout});

    # strip blanks
    $expression =~ s/\s+/ /g;
    $expression =~ s/^ //;
    $expression =~ s/ $//;

    my $request  = $self->create_request($expression, $src_lang_code,
        $dest_lang_code);
    my $response = $ua->request($request);

    if ($response->is_error())
    {
        if ($response->code =~ /50[03]/)
        {
            carp "timeout while translating '$expression'";
            return 'timeout';
        }
        else
        {
            carp "error (" . $response->code .
                ") while translating '$expression'";
            return 'error';
        }
    }
    my $content = $response->content();

    my @processed = $self->process_response($content, $src_lang_code,
        $dest_lang_code);
    my @result;

    my $at_bounds = $self->{match_at_bounds};
    while (@processed > 0)
    {
        my $left  = shift @processed;
        my $right = shift @processed;

        next unless
            $self->{matching} == M_EXACT ?
                &is_exact_match($expression, $left) :
            $self->{matching} == M_START ?
                &is_match_at_start($expression, $left, $at_bounds) :
            $self->{matching} == M_EXPR  ?
                &is_match_expr($expression, $left, $at_bounds) :
            $self->{matching} == M_WORDS ?
                &is_match_words($expression, $left, $at_bounds) :
            1;

        push @result, "$left = $right";
    }

    return @result;
}

sub get_trans_command
{
    my $self           = shift;
    my $expression     = shift;
    my $src_lang_code  = shift;
    my $dest_lang_code = shift;
    my $append         = shift;

    my $class = ref($self);

#    $append     =~ s/"/\\"/g;
#    $expression =~ s/"/\\"/g;


#    my $command = "runtrans";
#    $command.= " $class";
#    $command.= " -t " . $self->{timeout};
#    $command.= " -m " . ($self->{matching} == M_EXACT ? 'exact' :
#                         $self->{matching} == M_START ? 'start' :
#                         $self->{matching} == M_EXPR  ? 'expr'  :
#                         $self->{matching} == M_WORDS ? 'words' :
#                                                        'all'  );
#    $command.= " -b " if $self->{match_at_bounds};
#    $command.= " -d " . $src_lang_code . "2" . $dest_lang_code;
#    $command.= " -a \"$append\"";
#    $command.= " \"$expression\"";

    my @command;
    push @command, "runtrans", $class;
    push @command, "-t", $self->{timeout};
    push @command, "-m", ($self->{matching} == M_EXACT ? 'exact' :
                          $self->{matching} == M_START ? 'start' :
                          $self->{matching} == M_EXPR  ? 'expr'  :
                          $self->{matching} == M_WORDS ? 'words' :
                                                         'all'  );
    push @command, "-b" if $self->{match_at_bounds};
    push @command, "-d", $src_lang_code . "2" . $dest_lang_code;
    push @command, "-a", $append;
    push @command, $expression;

    return @command;
}

sub is_exact_match
{
    my $in_expr    = shift;
    my $found_expr = shift;

    return lc(&strip_grammar_info($in_expr)) eq
           lc(&strip_grammar_info($found_expr));
}

sub is_match_at_start
{
    my $in_expr    = shift;
    my $found_expr = shift;
    my $at_bounds  = shift;

    my $in_stripped    = &strip_grammar_info($in_expr);
    my $found_stripped = &strip_grammar_info($found_expr);

    return $at_bounds ?
        $found_stripped =~ /^\Q$in_stripped\E\b/g :
        $found_stripped =~ /^\Q$in_stripped\E/g   ;
}

sub is_match_expr
{
    my $in_expr    = shift;
    my $found_expr = shift;
    my $at_bounds  = shift;

    my $in_stripped    = &strip_grammar_info($in_expr);
    my $found_stripped = &strip_grammar_info($found_expr);

    return $at_bounds ?
        $found_stripped =~ /\b\Q$in_stripped\E\b/g :
        $found_stripped =~ /\Q$in_stripped\E/g     ;
}

sub is_match_words
{
    my $in_expr    = shift;
    my $found_expr = shift;
    my $at_bounds  = shift;

    my $in_stripped    = &strip_grammar_info($in_expr);
    my $found_stripped = &strip_grammar_info($found_expr);

    foreach my $word (split /\W+/, $in_stripped)
    {
        return undef
            unless $at_bounds ?
                $found_stripped =~ /\b\Q$word\E\b/g :
                $found_stripped =~ /\Q$word\E/g     ;
    }

    return 1;
}

sub strip_grammar_info
{
    my $expr = shift;
    $expr =  Encode::decode_utf8($expr)
        unless Encode::is_utf8($expr);
    $expr =~ s/\([^)]*\)//g;
    #$expr =~ s/, (r|e|s)\s*$//;
    $expr =~ s/;.*//;
    $expr =~ s/\W+/ /g;
    $expr =~ s/^ //;
    $expr =~ s/ $//;
    return $expr;
}

sub convert_to_utf8
{
    my $input_encoding = shift;
    my $string         = shift;

    $string = Encode::decode($input_encoding, $string);
    my $str_unescaped = HTML::Entities::decode_entities($string);

    # $str_escaped might be in Perl's internal format, need to encode it
    return Encode::is_utf8($str_unescaped) ?
        Encode::encode_utf8($str_unescaped) :
        $str_unescaped;
}

sub run
{
    my $self = shift;

    croak "no supported directions defined"
        unless (scalar(keys %{$self->{directions}}) > 0);

    my @options = $self->_get_options();
    return
        if @options < 7;

    my ($timeout, $matching, $at_bounds, $src_lang_code, $dest_lang_code,
        $append, $help) = @options;

    if ($help || @ARGV == 0)
    {
        $self->_print_usage();
        return;
    }

    $self->timeout($timeout);
    $self->match_at_bounds($at_bounds);
    $self->matching($matching);

    my $state;
    my $i = 0;
    foreach my $expr (@ARGV)
    {
        $i++;

        my @translations = $self->translate($expr, $src_lang_code,
            $dest_lang_code);

        if (@translations && $translations[0] !~ /=/)
        {
            $state = $translations[0];
            next;
        }
        $state = "ok";

        foreach my $trans (@translations)
            { print "$trans$append\n"; }

        print "\n" unless $i == @ARGV;
    }

    print $state . $append . "\n"
        if $append;
}

################################################################################
# private methods                                                              #
################################################################################

sub _get_options
{
    my $self = shift;

    my $timeout = $self->{timeout};
    my $matching_str;
    my $matching = $self->{timeout};
    my $at_bounds;
    my $direction;
    my $help;
    my $append = '';

    Getopt::Long::Configure("bundling");
    GetOptions(
        't=i' => \$timeout,
        'm=s' => \$matching_str,
        'b'   => \$at_bounds,
        'd=s' => \$direction,
        'a=s' => \$append,
        'h'   => \$help,
    );

    if (defined $matching_str)
    {
        $matching_str eq 'exact' ? $matching = M_EXACT :
        $matching_str eq 'start' ? $matching = M_START :
        $matching_str eq 'expr'  ? $matching = M_EXPR  :
        $matching_str eq 'words' ? $matching = M_WORDS :
        $matching_str eq 'all'   ? $matching = M_ALL   :
            do
            {
                warn "invalid matching type: '$matching_str'\n";
                return undef;
            }
    }

    if (defined $direction && $direction !~ /2/)
    {
        warn "invalid direction format: '$direction'\n";
        return undef;
    }

    my ($src_lang_code, $dest_lang_code) = defined $direction ?
        split /2/, $direction :
        undef;

    return ($timeout, $matching, $at_bounds, $src_lang_code, $dest_lang_code,
        $append, $help);
}

sub _print_usage
{
    my $self     = shift;
    my $host     = $self->{host_server};
    my $script   = $self->{script_name};
    my $timeout  = $self->{timeout};
    my $matching = $self->{matching};

    unless (defined $script)
    {
        $script = $0;
        $script =~ s|^.*/||;
    }

    my ($def_exact, $def_start, $def_expr, $def_words, $def_all) =
        ('', '', '', '', '');

    my $def_str = '(def)';
    $matching == M_EXACT ? $def_exact = $def_str :
    $matching == M_START ? $def_start = $def_str :
    $matching == M_EXPR  ? $def_expr  = $def_str :
    $matching == M_WORDS ? $def_words = $def_str :
                           $def_all   = $def_str ;

    my ($def_src_lang_code, $def_dest_lang_code) = $self->default_dir();
    my ($wd, $wl, $wr) = $self->_get_column_widths();

    my @dir_options;
    foreach my $src_lang_code (@{$self->{language_keys}})
    {
        foreach my $dest_lang_code (@{$self->{language_keys}})
        {
            next unless $self->is_supported_dir($src_lang_code,
                $dest_lang_code);

            my $dir_option = sprintf("%-${wd}s: %-${wl}s -> %-${wr}s",
                $src_lang_code . "2" . $dest_lang_code,
                ${$self->{languages}}{$src_lang_code},
                ${$self->{languages}}{$dest_lang_code});

            $dir_option .= " (default)"
                if ($src_lang_code eq $def_src_lang_code &&
                    $dest_lang_code eq $def_dest_lang_code);

            push @dir_options, $dir_option;
        }
    }

    my $indent = "                     ";
    my $directions = join("\n$indent", @dir_options);

    print <<EOF;
Multilingual dictionary metasearcher for $host
Usage: $script [options] expression [...]\ttranslate word(s)

Options:
   --              expressions to be translated follow
   -t <timeout>    wait for the response for <timeout> secs (default $timeout)
   -m <matching>   set matching type
                     exact: exact match only $def_exact
                     start: match at start of the translated expr. only $def_start
                     expr : match expr. anywhere in the translated expr. $def_expr
                     words: match expr. words in the translated expr. $def_words
                     all  : match anything to anything $def_all
   -b              match at word boundaries only
   -d <direction>  set translation direction
                     $directions
   -a <string>     append <string> to each line of output
   -h              print this help screen
EOF
}

sub _get_column_widths
{
    my $self = shift;

    my $max_dir_width  = 0;
    my $max_lcol_width = 0;
    my $max_rcol_width = 0;
    
    foreach my $src_lang_code (@{$self->{language_keys}})
    {
        foreach my $dest_lang_code (@{$self->{language_keys}})
        {
            next unless $self->is_supported_dir($src_lang_code,
                $dest_lang_code);
            my $dir_width  = length($src_lang_code . "2" . $dest_lang_code);
            my $lcol_width = length(${$self->{languages}}{$src_lang_code});
            my $rcol_width = length(${$self->{languages}}{$dest_lang_code});

            $max_dir_width = $dir_width
                if $dir_width > $max_dir_width;

            $max_lcol_width = $lcol_width
                if $lcol_width > $max_lcol_width;

            $max_rcol_width = $rcol_width
                if $rcol_width > $max_rcol_width;
        }
    }

    return ($max_dir_width, $max_lcol_width, $max_rcol_width);
}

# borrowed from LWP::MemberMixin
sub _elem
{
    my($self, $elem, $val) = @_;
    my $old = $self->{$elem};
    $self->{$elem} = $val if defined $val;
    return $old;
}

1;

__END__