File Coverage

blib/lib/Lingua/Stem/Snowball.pm

Criterion	Covered	Total	%
statement	58	69	84.0
branch	26	40	65.0
condition	3	6	50.0
subroutine	12	13	92.3
pod	7	7	100.0
total	106	135	78.5

package Lingua::Stem::Snowball;
use strict;
use warnings;
use 5.006002;

use Carp;
use Exporter;
use vars qw(
    $VERSION
    @ISA
    @EXPORT_OK
    $AUTOLOAD
    %EXPORT_TAGS
    $stemmifier
    %instance_vars
);

$VERSION = '0.952';

@ISA         = qw( Exporter DynaLoader );
%EXPORT_TAGS = ( 'all' => [qw( stemmers stem )] );
@EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );

require DynaLoader;
__PACKAGE__->bootstrap($VERSION);

# Ensure that C symbols are exported so that other shared libaries (e.g.
# KinoSearch) can use them.  See Dynaloader docs.
sub dl_load_flags {0x01}

# A shared home for the actual struct sb_stemmer C modules.
$stemmifier = Lingua::Stem::Snowball::Stemmifier->new;

%instance_vars = (
    lang              => '',
    encoding          => undef,
    locale            => undef,
    stemmer_id        => -1,
    strip_apostrophes => 0,
);

sub new {
    my $class = shift;
    my $self = bless { %instance_vars, @_ }, ref($class) || $class;

    # Validate lang, validate/guess encoding, and get an sb_stemmer.
    $self->lang( $self->{lang} );
    if ( !defined $self->{encoding} ) {
        $self->{encoding}
            = $self->{lang} eq 'ru' ? 'KOI8-R'
            : $self->{lang} eq 'ro' ? 'ISO-8859-2'
            : $self->{lang} eq 'tr' ? 'UTF-8'
            :                         'ISO-8859-1';
    }
    $self->_derive_stemmer;

    return $self;
}

sub stem {
    my ( $self, $lang, $words, $locale, $is_stemmed );

    # Support lots of DWIMmery.
    if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
        ( $self, $words, $is_stemmed ) = @_;
    }
    else {
        ( $lang, $words, $locale, $is_stemmed ) = @_;
        $self = __PACKAGE__->new( lang => $lang );
    }

    # Bail if we don't have a valid lang.
    return undef unless $self->{lang};

    # Bail if there's no input.
    return undef unless ( ref($words) or length($words) );

    # Duplicate the input array and transform it into an array of stems.
    $words = ref($words) ? $words : [$words];
    my @stems = map {lc} @$words;
    $self->stem_in_place( \@stems );

    # Determine whether any stemming took place, if requested.
    if ( ref($is_stemmed) ) {
        $$is_stemmed = 0;
        if ( $self->{stemmer_id} == -1 ) {
            $$is_stemmed = 1;
        }
        else {
            for ( 0 .. $#stems ) {
                next if $stems[$_] eq $words->[$_];
                $$is_stemmed = 1;
                last;
            }
        }
    }

    return wantarray ? @stems : $stems[0];
}

sub lang {
    my ( $self, $lang ) = @_;
    if ( defined $lang ) {
        $lang = lc($lang);
        $lang = $lang eq 'dk' ? 'nl' : $lang;    # backwards compat
        if ( _validate_language($lang) ) {
            $self->{lang} = $lang;
            # Force stemmer_id regen at next call to stem_in_place().
            $self->{stemmer_id} = -1;
        }
        else {
            $@ = "Language '$lang' does not exist";
        }
    }
    return $self->{lang};
}

sub encoding {
    my ( $self, $encoding ) = @_;
    if ( defined $encoding ) {
        croak("Invalid value for encoding: '$encoding'")
            unless $encoding =~ /^(?:UTF-8|KOI8-R|ISO-8859-[12])$/;
        $self->{encoding} = $encoding;
        # Force stemmer_id regen at next call to stem_in_place().
        $self->{stemmer_id} = -1;
    }
    return $self->{encoding};
}

# Deprecated, has no effect on stemming behavior.
sub strip_apostrophes {
    my ( $self, $boolean ) = @_;
    if ( defined $boolean ) {
        $self->{strip_apostrophes} eq $boolean ? 1 : 0;
    }
    return $self->{strip_apostrophes};
}

# Deprecated, has no effect on stemming behavior.
sub locale {
    my ( $self, $locale ) = @_;
    if ($locale) {
        $self->{locale} = $locale;
    }
    return $self->{locale};
}

1;

__END__