File Coverage

blib/lib/Text/Language/Guess.pm

Criterion	Covered	Total	%
statement	83	85	97.6
branch	10	14	71.4
condition	4	6	66.6
subroutine	16	16	100.0
pod	5	8	62.5
total	118	129	91.4

###########################################
# Text::Language::Guess
# 2005, Mike Schilli
###########################################

###########################################
package Text::Language::Guess;
###########################################

use strict;
use warnings;
use vars qw(%STOPMAPS $VERSION);

use Log::Log4perl qw(:easy);
use Text::ExtractWords;
use Lingua::StopWords;
use File::Spec;
use File::Basename;

%STOPMAPS = ();
$VERSION  = "0.02";

###########################################
sub new {
###########################################
    my($class, @options) = @_;

    my $self = {
        languages => languages(),
        @options,
    };

    bless $self, $class;

        # To avoid re-initializing the stopmap (which is fairly expensive)
        # on every new(), hold all stopmaps for pre-computed language
        # combinations in a class variable.
    if(exists $STOPMAPS{"@{$self->{languages}}"}) {
        $self->{stopmap} = $STOPMAPS{"@{$self->{languages}}"};
    } else {
        $self->{stopmap} = $self->stopwords();
        $STOPMAPS{"@{$self->{languages}}"} = $self->{stopmap};
    }

    return $self;
}

###########################################
sub scores {
###########################################
    my($self, $file) = @_;

    return $self->scores_string(slurp($file));
}

###########################################
sub scores_string {
###########################################
    my($self, $data) = @_;

    my @words = ();
    my %scores = ();

    LOGDIE "Cannot score empty/undefined document" if
        !defined $data or !length $data;

    words_list(\@words, $data, {});

    for my $word (@words) {
        my $langs = $self->{stopmap}->{$word};

        if(! defined $langs) {
            DEBUG "$word doesn't match any language";
            next;
        }

        for my $lang (@$langs) {
            DEBUG "Scoring for $lang";
            $scores{$lang}++;
        }
    }

    return \%scores;
}

###########################################
sub language_guess {
###########################################
    my($self, $file) = @_;

    return $self->language_guess_string(slurp($file));
}

###########################################
sub language_guess_string {
###########################################
    my($self, $data) = @_;

    my $scores = $self->scores_string($data);

    my $best_lang;
    my $max_score;

    for my $lang (keys %$scores) {
        if(!defined $max_score or
            $max_score < $scores->{$lang}) {
            $best_lang = $lang;
            $max_score = $scores->{$lang};
        }
    }

    return $best_lang;
}

###########################################
sub stopwords {
###########################################
    my($self) = @_;

    # Fetch all stopword lists from all supported languages

    my $stopmap = {};

    for my $lang (@{$self->{languages}}) {

        DEBUG "Loading language $lang";

        my $stopwords = Lingua::StopWords::getStopWords($lang);

        for my $stopword (keys %$stopwords) {
            DEBUG "Pushing $stopword => $lang";
            push @{$stopmap->{$stopword}}, $lang;
        }
    }

    return $stopmap;
}

###########################################
sub languages {
###########################################

    # Check which languages are supported by Lingua::StopWords

    for my $dir (@INC) {
        if(-f File::Spec->catfile($dir, "Lingua/StopWords.pm")) {
            return [map { s/\.pm$//; lc basename($_); }
                        <$dir/Lingua/StopWords/*.pm>];
        }
    }
}

###########################################
sub slurp {
###########################################
    my($file) = @_;

    LOGDIE "$file not a file" unless -f $file;

    local $/ = undef;

    my $data;

    open FILE, "<$file" or LOGDIE "Cannot open $file ($!)";
    $data = ;
    close FILE;
    return $data;
}

1;

__END__