File Coverage

blib/lib/AltaVista/BabelFish.pm

Criterion	Covered	Total	%
statement	40	139	28.7
branch	7	88	7.9
condition	9	29	31.0
subroutine	10	17	58.8
pod	10	11	90.9
total	76	284	26.7

package AltaVista::BabelFish;

use strict;
use warnings;
use version; our $VERSION = qv('42.0.2');

use Class::Std;
use Class::Std::Utils;

my %lang = (
    'zh' => {
        'name'    => 'Chinese Simplified',
        'targets' => [qw(en)],
    },
    'zt' => {
        'name'    => 'Chinese Traditional',
        'targets' => [qw(en)],
    },
    'en' => {
        'name'    => 'English',
        'targets' => [qw(es zh zt nl fr de el it ja ko pt ru)],
    },
    'nl' => {
        'name'    => 'Dutch',
        'targets' => [qw(en fr)],
        'native'  => 'Nederlands',
    },
    'fr' => {
        'name'    => 'French',
        'targets' => [qw(en nl de el it pt es)],
    },
    'de' => {
        'name'    => 'German',
        'targets' => [qw(en fr)],
    },
    'el' => {
        'name'    => 'Greek',
        'targets' => [qw(en fr)],
    },
    'it' => {
        'name'    => 'Italian',
        'targets' => [qw(en fr)],
        'native'  => 'Italiano',
    },
    'ja' => {
        'name'    => 'Japanese',
        'targets' => [qw(en)],
    },
    'ko' => {
        'name'    => 'Korean',
        'targets' => [qw(en)],
    },
    'pt' => {
        'name'    => 'Portuguese',
        'targets' => [qw(en fr)],
    },
    'ru' => {
        'name'    => 'Russian',
        'targets' => [qw(en)],
    },
    'es' => {
        'name'    => 'Spanish',
        'targets' => [qw(en fr)],
    },
);

# make seperator $SimpleMood::DEATHSTAR: :=-=: ??
my %alta = (
    'seperator'     => 'Perl_AltaVista_BabelFish_DanMuey',
    'url'           => 'http://babelfish.altavista.com/tr',
    'form'          => {
        'doit' => 'done',
        'intl' => '1',
        'tt'   => 'urltext',
    },
    'urltext_param' => 'urltext',
    'lp_param'      => 'lp',
    'pre'           => '',
    'pst'           => '',
    'q_pre'         => '',
    'q_pst'         => '',
#   'q_pre'         => 'input type=hidden name="q" value="',
#   'q_pst'         => '"',
    'kls_pre'       => 'input type="hidden" name="kls" value="',
    'kls_pst'       => '"',
    'ienc_pre'      => 'input type="hidden" name="ienc" value="',
    'ienc_pst'      => '"',
);

{ # start encapsulation of inside out object

    my %source :ATTR(init_arg => 'source', get => 'source');
    my %target :ATTR(init_arg => 'target', get => 'target');
    my %errstr :ATTR(get => 'errstr');

    sub BUILD {
         my ($self, $ident, $args_ref) = @_;
         $source{ $ident } = defined $args_ref->{'source'}
                             && exists $lang{ $args_ref->{'source'} }
                             ? $args_ref->{'source'} : 'en';
         $target{ $ident } = $args_ref->{'target'}  || '';

         $self->set_source( $source{ $ident } );
         $self->set_target( $target{ $ident } );

         $errstr{ $ident } = undef;

         return;
    }

    sub set_source {
        my ($self, $_source) = @_;
        my $ident = ident $self;
        $source{ $ident } = $_source if defined $_source
                               && exists $lang{ $_source };
        if(!defined $target{ $ident }
            || !grep /^\Q$target{ $ident }\E$/,
            @{ $lang{ $source{ $ident } }->{'targets'} }) {

            $target{ $ident } = $lang{ $source{ $ident } }->{'targets'}->[0];
        }
        return $source{ $ident };
    }

    sub set_target {
        my($self, $_target) = @_;
        my $ident = ident $self;
        $target{ $ident } = $_target
            if defined $_target &&  exists $lang{ $_target }
            && grep /^\Q$target{ $ident }\E$/,
                @{ $lang{ $source{ $ident } }->{'targets'} };
         return $target{ $ident };
    }

    sub get_english {
         my ($self, $_lang) = @_;
         my $lnx = exists $lang{ $_lang } ? $_lang : $source{ ident $self };
         return $lang{ $lnx }->{'name'};
    }

    sub get_native {
         my ($self, $_lang) = @_;
         my $name = undef;
         return $lang{ $_lang}->{'native'} if exists $lang{ $_lang}->{'native'};
         require Locales::Language; # only need it here :)
         eval {
             $name = Locales::Language->new( $_lang )->code2language( $_lang );
         }; # eval since this dies a lot...
         return $name;
         # return scalar $self->translate( $self->get_english($_lang), 'en', $_lang ); # or cache in hash native => '',
    }

    sub get_source_languages_arrayref {
         my ($self, $_lang) = @_;
         $_lang = defined $_lang && exists $lang{ $_lang } ? $_lang : '';
         my @target;
         if($_lang) {
             for(keys %lang) {
                 push @target, $_ if grep /^\Q$_lang\E$/,
                      @{ $lang{$_}->{'targets'} };
             }
             # list all languages that can be translated into this lang
             return \@target;
         }
         return [keys %lang]; # list all source languages
    }

    sub get_target_languages_arrayref {
         my ($self, $_lang) = @_;
         $_lang = defined $_lang && exists $lang{ $_lang }
                  ? $_lang : $source{ ident $self };
         return $lang{ $_lang }->{'targets'};
    }

    sub translate {
        my ($self, $text, $_source, $_target) = @_;

        my $current_source = $self->get_source();
        my $current_target = $self->get_target();
        $self->set_source( $_source ) if $_source;
        $self->set_target( $_target ) if $_target;

        if(ref $text eq 'ARRAY') {
            $alta{'seperator'} =~ s/\W//g;
            my $str = join " \n\n$alta{'seperator'}\n\n ", @{ $text };
            my ($pre,$x,$y) = $self->translate($str) or return undef;

            $self->set_source( $current_source ) if $_source;
            $self->set_target( $current_target ) if $_target;

            return ([split / \n\n$alta{'seperator'}\n\n /, $pre], $x, $y)
                if wantarray;
            return  [split / \n\n$alta{'seperator'}\n\n /, $pre]
        }
        else {
            use LWP::UserAgent;
            $alta{'form'}->{ $alta{'urltext_param'} } = $text; # url encode?
            $alta{'form'}->{ $alta{'lp_param'} }
                = "$source{ ident $self }\_$target{ ident $self }";

            my $agt = new LWP::UserAgent;
            $agt->agent("Perl Module: AltaVista::BabelFish/$VERSION "
                        . '(c) Dan Muey/2005');
            my $res = $agt->post($alta{url}, $alta{form});

            $errstr{ ident $self } = $res->status_line()
                if !$res->is_success();
            return undef if !$res->is_success();
            my $cnt = $res->content();

            my ($parse_me) = $cnt
                =~ m/\Q$alta{'pre'}\E(.*)\Q$alta{'pst'}\E/si;
            my ($tr)       = $parse_me
                =~ m/\Q$alta{'q_pre'}\E([^\"]*)\Q$alta{'q_pst'}\E/si;
            my ($k)        = $parse_me
                =~ m/\Q$alta{'kls_pre'}\E([^\"]*)\Q$alta{'kls_pst'}\E/si;
            my ($i)        = $parse_me
                =~ m/\Q$alta{'ienc_pre'}\E([^\"]*)\Q$alta{'ienc_pst'}\E/si;
            # set to empty instead of undef to avoid warnings
            $tr = '' if !defined $tr;
            $k  = '' if !defined $k;
            $i  = '' if !defined $i;

            $self->set_source( $current_source ) if $_source;
            $self->set_target( $current_target ) if $_target;

            return ($tr, $k, $i) if wantarray;
            return $tr;
        }
    }

    sub get_languages_hashref {
        return \%lang;
    }

    sub is_latest_version {
        my($self) = @_;
        my $ident = ident $self;
        my ($cpan, $ior) = ('', '');

        eval 'use CPAN;';

        if($@) {
            $errstr{ $ident } = $@;
            return 0;
        }

        eval <<'REDIRECT_END';
            use IO::Redirect;
            $ior = IO::Redirect->new();
            $ior->redirect_stdout_stderr(\$cpan);
REDIRECT_END

        my $mod = CPAN::Shell->expand('Module', 'AltaVista::BabelFish');

        if(defined $mod) {
            if($VERSION eq $mod->cpan_version) {
                if(ref $ior) {
                    $ior->un_redirect_stdout_stderr();
                }
                return 1;
            }
            else {
                $errstr{ $ident } = "Installed Version: $VERSION\nLatest "
                                    . 'version: ' . $mod->cpan_version();
            }
        }
        else {
            $errstr{ $ident }
                = "Undefined CPAN Object. Here is what CPAN said:\n$cpan"
                    if ref $ior;
            $errstr{ $ident } = "Undefined CPAN Object." if !ref $ior;
        }

        if(ref $ior) {
            $ior->un_redirect_stdout_stderr();
        }

        return;
    }

    sub fishinfo {
        my($self, $use_native) = @_;
        my $title
            = "AltaVista::BabelFish Perl module $VERSION by Daniel Muey";
        my $url   = 'http://search.cpan.org/~dmuey/AltaVista-BabelFish-'
                  . "$VERSION/BabelFish.pm";
        my $html  = -t STDIN ? 0 : 1;
        my $fish  = AltaVista::BabelFish->new;
        my $out   = $html
            ? qq($title\n)
              . qq(Click here)
              . " for documentation.\n\n"
            : "$title\nSee `perldoc AltaVista::BabelFish` or $url"
              . " for documentation\n\n";

        for my $src (sort @{ $fish->get_source_languages_arrayref() }) {
            my $native  = $use_native && $src ne 'en'
                          ? $fish->get_native($src) : '';
            my $english = $fish->get_english($src);
            $native = $native && $native ne $english ? "[$native] " : '';
            $out .= "  " if $html;
            $out .= "$native$english ($src) translates into:\n";
            $out .= "     \n" if $html;
            for(sort @{ $fish->get_target_languages_arrayref($src) }) {
                $out .= "      \n" if $html;
                $out .= "        " . $fish->get_english($_) . " ($_)\n";
                $out .= "      \n" if $html;
            }
            $out .= "     \n" if $html;
            $out .= "  \n" if $html;
            $out .= "\n";
        }

        $out .= "\n" if $html;

        if(!defined wantarray) {
            print $out;
        }
        else {
            return $out;
        }
    }

} # end encapsulation of inside out object

1; # yes I'd like to do "42;" but warnings doesn't like it :)

__END__