File Coverage

blib/lib/Lingua/Stem.pm

Criterion	Covered	Total	%
statement	113	162	69.7
branch	29	56	51.7
condition	0	3	0.0
subroutine	11	13	84.6
pod	10	10	100.0
total	163	244	66.8

package Lingua::Stem;

# $RCSfile: Stem.pm,v $ $Revision: 1.2 $ $Date: 1999/06/16 17:45:28 $ $Author: snowhare $

use strict;
require Exporter;
use Lingua::Stem::AutoLoader;

BEGIN {
    $Lingua::Stem::VERSION     = '0.84';
    @Lingua::Stem::ISA         = qw (Exporter);
    @Lingua::Stem::EXPORT      = ();
    @Lingua::Stem::EXPORT_OK   = qw (stem stem_in_place clear_stem_cache stem_caching add_exceptions delete_exceptions get_exceptions set_locale get_locale);
    %Lingua::Stem::EXPORT_TAGS = ( 'all' => [qw (stem stem_in_place stem_caching clear_stem_cache add_exceptions delete_exceptions get_exceptions set_locale get_locale)],
                    'stem' => [qw (stem)],
           'stem_in_place' => [qw (stem_in_place)],
                 'caching' => [qw (stem_caching clear_stem_cache)],
                  'locale' => [qw (set_locale get_locale)],
              'exceptions' => [qw (add_exceptions delete_exceptions get_exceptions)],
                 );
}

my $defaults = {
            -locale       => 'en',
           -stemmer       => \&Lingua::Stem::En::stem,
           -stem_in_place => \&Lingua::Stem::En::stem,
      -stem_caching       => \&Lingua::Stem::En::stem_caching,
  -clear_stem_cache       => \&Lingua::Stem::En::clear_stem_cache,
        -exceptions       => {},
      -known_locales => {
                          'da' => { -stemmer => \&Lingua::Stem::Da::stem,
                               -stem_caching => \&Lingua::Stem::Da::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Da::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'da' locale"); },
                           },
                          'de' => { -stemmer => \&Lingua::Stem::De::stem,
                               -stem_caching => \&Lingua::Stem::De::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::De::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'de' locale"); },
                           },
                          'en' => { -stemmer => \&Lingua::Stem::En::stem,
                               -stem_caching => \&Lingua::Stem::En::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En::clear_stem_cache,
                           -stem_in_place    => \&Lingua::Stem::En::stem,
                           },
                       'en_us' => { -stemmer => \&Lingua::Stem::En::stem,
                               -stem_caching => \&Lingua::Stem::En::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En::clear_stem_cache,
                           -stem_in_place    => \&Lingua::Stem::En::stem,
                           },
                       'en-us' => { -stemmer => \&Lingua::Stem::En::stem,
                               -stem_caching => \&Lingua::Stem::En::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En::clear_stem_cache,
                           -stem_in_place    => \&Lingua::Stem::En::stem,
                           },
                       'en_uk' => { -stemmer => \&Lingua::Stem::En::stem,
                               -stem_caching => \&Lingua::Stem::En::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En::clear_stem_cache,
                           -stem_in_place    => \&Lingua::Stem::En::stem,
                           },
                       'en-uk' => { -stemmer => \&Lingua::Stem::En::stem,
                               -stem_caching => \&Lingua::Stem::En::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En::clear_stem_cache,
                           -stem_in_place    => \&Lingua::Stem::En::stem,
                           },
                   'en-broken' => { -stemmer => \&Lingua::Stem::En_Broken::stem,
                               -stem_caching => \&Lingua::Stem::En_Broken::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::En_Broken::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'en-broken' locale"); },
                           },
                          'fr' => { -stemmer => \&Lingua::Stem::Fr::stem,
                               -stem_caching => \&Lingua::Stem::Fr::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Fr::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'fr' locale"); },
                           },
                          'gl' => { -stemmer => \&Lingua::Stem::Gl::stem,
                               -stem_caching => \&Lingua::Stem::Gl::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Gl::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'gl' locale"); },
                           },
                          'it' => { -stemmer => \&Lingua::Stem::It::stem,
                               -stem_caching => \&Lingua::Stem::It::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::It::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'it' locale"); },
                           },
                          'no' => { -stemmer => \&Lingua::Stem::No::stem,
                               -stem_caching => \&Lingua::Stem::No::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::No::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'no' locale"); },
                           },
                          'pt' => { -stemmer => \&Lingua::Stem::Pt::stem,
                               -stem_caching => \&Lingua::Stem::Pt::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Pt::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'pt' locale"); },
                           },
                          'sv' => { -stemmer => \&Lingua::Stem::Sv::stem,
                               -stem_caching => \&Lingua::Stem::Sv::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Sv::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'sv' locale"); },
                           },
                          'ru' => { -stemmer => \&Lingua::Stem::Ru::stem,
                               -stem_caching => \&Lingua::Stem::Ru::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Ru::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'ru' locale"); },
                           },
                          'ru_ru' => {
                                    -stemmer => \&Lingua::Stem::Ru::stem,
                               -stem_caching => \&Lingua::Stem::Ru::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Ru::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'ru_ru' locale"); },
                           },
                          'ru-ru' => {
                                    -stemmer => \&Lingua::Stem::Ru::stem,
                               -stem_caching => \&Lingua::Stem::Ru::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Ru::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'ru-ru' locale"); },
                           },
                          'ru-ru.koi8-r' => {
                                    -stemmer => \&Lingua::Stem::Ru::stem,
                               -stem_caching => \&Lingua::Stem::Ru::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Ru::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'ru-ru.koi8-r' locale"); },
                           },
                          'ru_ru.koi8-r' => {
                                    -stemmer => \&Lingua::Stem::Ru::stem,
                               -stem_caching => \&Lingua::Stem::Ru::stem_caching,
                           -clear_stem_cache => \&Lingua::Stem::Ru::clear_stem_cache,
                           -stem_in_place    => sub { require Carp; Carp::croak("'stem_in_place' not available for 'ru_ru.koi8-r' locale"); },
                           },
                   },
};

###

sub new {
    my $proto = shift;
    my $package = __PACKAGE__;
    my $proto_ref = ref($proto);
    my $class;
    if ($proto_ref) {
        $class = $proto_ref;
    } elsif ($proto) {
        $class = $proto;
    } else {
        $class = $package;
    }
    my $self = bless {},$class;

    # Set the defaults
    %{$self->{'Lingua::Stem'}->{-exceptions}}     = %{$defaults->{-exceptions}};
    $self->{'Lingua::Stem'}->{-locale}            = $defaults->{-locale};
    $self->{'Lingua::Stem'}->{-stemmer}           = $defaults->{-stemmer};
    $self->{'Lingua::Stem'}->{-stem_in_place}     = $defaults->{-stem_in_place};
    $self->{'Lingua::Stem'}->{-stem_caching}      = $defaults->{-stem_caching};
    $self->{'Lingua::Stem'}->{-clear_stem_cache}  = $defaults->{-clear_stem_cache};

    # Handle any passed parms
    my @errors = ();
    if ($#_ > -1) {
        my $parm_ref = $_[0];
        if (not ref $parm_ref) {
            $parm_ref = {@_};
        }
        foreach my $key (keys %$parm_ref) {
            my $lc_key = lc ($key);
            if    ($lc_key eq '-locale')         { $self->set_locale($parm_ref->{$key});            }
            elsif ($lc_key eq '-default_locale') { set_locale($parm_ref->{$key});                   }
            else                                 { push (@errors," '$key' => '$parm_ref->{$key}'"); }
        }
    }
    if ($#errors > -1) {
        require Carp;
        Carp::croak ($package . "::new() - unrecognized parameters passed:" . join(', ',@errors));
    }

    return $self;
}

###

sub set_locale {
    my ($self)   = shift;

    my ($locale);
    if (ref $self) {
        ($locale) = @_;
        $locale   = lc $locale;
        if (not exists $defaults->{-known_locales}->{$locale}) {
            require Carp;
            Carp::croak (__PACKAGE__ . "::set_locale() - Unknown locale '$locale'");
        }
        $self->{'Lingua::Stem'}->{-locale}           = $locale;
        $self->{'Lingua::Stem'}->{-stemmer}          = $defaults->{-known_locales}->{$locale}->{-stemmer};
        $self->{'Lingua::Stem'}->{-stem_in_place}    = $defaults->{-known_locales}->{$locale}->{-stem_in_place};
        $self->{'Lingua::Stem'}->{-stem_caching}     = $defaults->{-known_locales}->{$locale}->{-stem_caching};
        $self->{'Lingua::Stem'}->{-clear_stem_cache} = $defaults->{-known_locales}->{$locale}->{-clear_stem_cache};
    } else {
        $locale = lc $self;
        if (not exists $defaults->{-known_locales}->{$locale}) {
            require Carp;
            Carp::croak (__PACKAGE__ . "::set_locale() - Unknown locale '$locale'");
        }
        $defaults->{-locale}           = $locale;
        $defaults->{-stemmer}          = $defaults->{-known_locales}->{$locale}->{-stemmer};
        $defaults->{-stem_in_place}    = $defaults->{-known_locales}->{$locale}->{-stem_in_place};
        $defaults->{-stem_caching}     = $defaults->{-known_locales}->{$locale}->{-stem_caching};
        $defaults->{-clear_stem_cache} = $defaults->{-known_locales}->{$locale}->{-clear_stem_cache};
    }
    return;
}

###

sub get_locale {
    my $self = shift;

    if (ref $self) {
        return $self->{'Lingua::Stem'}->{-locale};
    } else {
        return $defaults->{-locale};
    }
}

###

sub add_exceptions {
    my $self;

    my ($exceptions, $exception_list);
    my $reference = ref $_[0];
    if ($reference eq 'HASH') {
        ($exceptions) =  @_;
        $exception_list = $defaults->{-exceptions};
    } elsif (not $reference) {
        $exceptions = { @_ };
        $exception_list = $defaults->{-exceptions};
    } else {
        $self = shift;
        ($exceptions) = @_;
        $exception_list = $self->{'Lingua::Stem'}->{-exceptions};
    }
    while (my ($exception,$replace_with) = each %$exceptions) {
            $exception_list->{$exception} = $replace_with;
    }
    return;
}

###

sub delete_exceptions {
    my $self;

    my ($exception_list,$exceptions);
    if ($#_ == -1) {
        $defaults->{-exceptions} = {};
        return;
    }
    my $reference =ref $_[0];
    if ($reference eq 'ARRAY') {
        ($exceptions) =  @_;
        $exception_list = $defaults->{-exceptions};
    } elsif (not $reference) {
        $exceptions = [@_];
        $exception_list = $defaults->{-exceptions};
    } else {
        $self = shift;
        if ($#_ == -1) {
            $self->{'Lingua::Stem'}->{-exceptions} = {};
        } else {
            $reference = ref $_[0];
            if ($reference eq 'ARRAY') {
                ($exceptions) =  @_;
                $exception_list = $self->{'Lingua::Stem'}->{-exceptions};
            } else {
                ($exceptions) = [@_];
                $exception_list = $self->{'Lingua::Stem'}->{-exceptions};
            }
        }
    }

    foreach (@$exceptions) { delete $exception_list->{$_}; }
    return;
}

###

sub get_exceptions {

    my $exception_list = {};
    if ($#_ == -1) {
        %$exception_list = %{$defaults->{-exceptions}};
        return $exception_list;
    }
    my $reference = ref $_[0];
    if ($reference eq 'ARRAY') {
        %$exception_list = %{$defaults->{-exceptions}};
    } elsif ($reference) {
        my $self = shift;
        if ($#_ > -1) {
            foreach (@_) {
                $exception_list->{$_} = $self->{'Lingua::Stem'}->{-exceptions}->{$_};
            }
        } else {
            %$exception_list = %{$self->{'Lingua::Stem'}->{-exceptions}};
        }
    } else {
        foreach (@_) {
            $exception_list->{$_} = $_;
        }
    }
    return $exception_list;
}

####

sub stem {
    my $self;
    return [] if ($#_ == -1);
    my ($exceptions,$locale,$stemmer);
    if (ref $_[0]) {
        my $self = shift;
        $exceptions = $self->{'Lingua::Stem'}->{-exceptions};
        $stemmer    = $self->{'Lingua::Stem'}->{-stemmer};
        $locale     = $self->{'Lingua::Stem'}->{-locale};
    } else {
        $exceptions = $defaults->{-exceptions};
        $stemmer    = $defaults->{-stemmer};
        $locale     = $defaults->{-locale};
    }
    &$stemmer({ -words => \@_,
               -locale => $locale,
           -exceptions => $exceptions });
}

###

sub stem_in_place {
    my $self;
    return [] if ($#_ == -1);
    my ($exceptions,$locale,$stemmer);
    if (ref $_[0]) {
        my $self = shift;
        $exceptions = $self->{'Lingua::Stem'}->{-exceptions};
        $stemmer    = $self->{'Lingua::Stem'}->{-stem_in_place};
        $locale     = $self->{'Lingua::Stem'}->{-locale};
    } else {
        $exceptions = $defaults->{-exceptions};
        $stemmer    = $defaults->{-stem_in_place};
        $locale     = $defaults->{-locale};
    }
    &$stemmer({ -words => [\@_],
               -locale => $locale,
           -exceptions => $exceptions });
}

###

sub clear_stem_cache {
    my $clear_stem_cache_sub;
    if (ref $_[0]) {
        my $self = shift;
        $clear_stem_cache_sub = $self->{'Lingua::Stem'}->{-clear_stem_cache};
    } else {
        $clear_stem_cache_sub = $defaults->{-clear_stem_cache};
    }
    &$clear_stem_cache_sub;
}

###

sub stem_caching {
    my $stem_caching_sub;
    my $first_parm_ref = ref $_[0];
    if ($first_parm_ref && ($first_parm_ref ne 'HASH')) {
        my $self = shift;
        $stem_caching_sub = $self->{'Lingua::Stem'}->{-stem_caching};
    } else {
        $stem_caching_sub = $defaults->{-stem_caching};
    }
    &$stem_caching_sub(@_);
}

1;