Text::Phonetic - A base class for phonetic algorithms

  use Text::Phonetic::Metaphone;

  my $phonetic = Text::Phonetic::Metaphone->new();
  $encoded_string = $phonetic->encode($string);
  @encoded_list = $phonetic->encode(@list);

  my $same = $phonetic->compare($string1,$string2);

  use Text::Phonetic;
  my $phonetic = Text::Phonetic->load( algorithm => 'Phonix' );
  $encoded_string = $phonetic->encode($string);

 $obj = Text::Phonetic::SUBCLASS->new(%PARAMETERS)

 $obj = Text::Phonetic->new(algorithm => $algorithm, %PARAMETERS)

 $RETURN_STRING = $obj->encode($STRING);
 OR
 @RETURN_LIST = $obj->encode(@LIST);
 OR
 $RETURN_LIST_REF = $obj->encode(@LIST);

 $RETURN_CODE = $obj->compare($STRING1,$STRING2);

 my @available = Text::Phonetic->available_algorithms;

 $RESULT = $obj->_do_encode($STRING);

 $RETURN_STRING = $obj->_do_compare($RESULT1,$RESULT2);

 package Text::Phonetic::MyAlgorithm;
 use Moose;
 extends qw(Text::Phonetic);

 has someattribute => (
    is  => 'rw',
    isa => 'Str',
 );

 __PACKAGE__->meta->make_immutable;

 sub _do_encode {
     my ($self,$string) = @_;
     # Do something
     return $phonetic_representation;
 }
 1;

    Maroš Kollár
    CPAN ID: MAROS
    maros [at] k-1.com
    http://www.k-1.com

# ============================================================================
package Text::Phonetic;
# ============================================================================
use Moose;
use utf8;

use Text::Unidecode qw();
use Carp;
use Module::Find;

use version;
our $AUTHORITY = 'cpan:MAROS';
our $VERSION = version->new("2.03");

use 5.008000;

our $DEFAULT_ALGORITHM = 'Phonix';
our @AVAILABLE_ALGORITHMS = grep { s/^Text::Phonetic::(.+)$/$1/x } 
    findsubmod Text::Phonetic;

has 'unidecode' => (
    is              => 'rw',
    isa             => 'Bool',
    default         => 1,
    required        => 1,
    documentation   => q[Transliterate strings to ASCII before processing]
);

after 'BUILDARGS' => sub { 
    my ($class) = @_;
    $class->check_predicates;
};

__PACKAGE__->meta->make_immutable;

# ----------------------------------------------------------------------------
# Class methods

sub available_algorithms {
    return @AVAILABLE_ALGORITHMS;
}

sub register_algorithm {
    my ($class,$algorithm) = @_;
    push @AVAILABLE_ALGORITHMS,$algorithm
        unless grep { $algorithm eq $_ } @AVAILABLE_ALGORITHMS;
    return $algorithm;
}

sub check_predicates {
    my ($class) = @_;
    
    if ($class->can('_predicates')) {
        my @predicates = $class->_predicates;
        foreach my $predicate (@predicates) {
            my $ok = eval {
                Class::MOP::load_class($predicate);
            };
            if (! $ok || $@) {
                croak("Could not load '$class' phonetic algorithm: Predicate '$predicate' is missing")
            }
        }
    }
}

# ----------------------------------------------------------------------------
# Constructor (new provided by Moose)

sub load {
    my $self = shift;
    my $params = (scalar @_ == 1 && ref($_[0]) eq 'HASH') ? shift : { @_ };
    
    my $algorithm = delete($params->{algorithm}) || $DEFAULT_ALGORITHM;
    my $class = __PACKAGE__.'::'.$algorithm;
    
    unless (grep { $algorithm eq $_ } @AVAILABLE_ALGORITHMS) {
        croak("Could not load '$algorithm' phonetic algorithm: Algorithm not available");
    }
    
    unless (Class::MOP::is_class_loaded($class)) {
        my $ok = eval {
            Class::MOP::load_class($class);
        };
        if (! $ok || $@) {
            my $error = $@ || 'Unknown error while loading '.$class;
            croak("Could not load '$algorithm' phonetic algorithm: $error")
        }
    }
    
    $class->check_predicates;
    
    return $class->new($params);
}



# ----------------------------------------------------------------------------
# Public methods

sub encode {
    my $self = shift;
    
    
    # Single value
    if (scalar(@_) == 1) {
        my $string = shift;
        $string = Text::Unidecode::unidecode($string) 
            if ($self->unidecode);
        return 
            unless defined $string && $string !~ /^\s*$/;
        return $self->_do_encode($string);
    # Expand list
    } elsif (scalar(@_) > 1) {
        my @result_list;
        foreach my $string (@_) {
            push @result_list,$self->encode($string);
        }
        return wantarray ? @result_list : \@result_list;
    }
    # Fallback
    return;
}


sub compare {
    my ($self,$string1,$string2) = @_;

    return 0 unless defined $string1 && $string1 !~ /^\s*$/;
    return 0 unless defined $string2 && $string2 !~ /^\s*$/;

    # Extremely rare case ;-)    
    return 100 if ($string1 eq $string2);

    if ($self->unidecode) {
        $string1 = Text::Unidecode::unidecode($string1);
        $string2 = Text::Unidecode::unidecode($string2);
        
        # Also not very likely, but has to be checked
        return 99 if ($string1 eq $string2);
    }
    
    my $value1 = $self->_do_encode($string1);
    my $value2 = $self->_do_encode($string2);
    
    return 0 unless (defined $value1 && defined $value2);
    
    return $self->_do_compare($self->_do_encode($string1),$self->_do_encode($string2));
}
    
sub _do_compare {
    my ($self,$result1,$result2) = @_;
    
    return 50 if ($result1 eq $result2);
    return 0;
}

sub _do_encode {
    carp('_do_encode is an abstract method!');
}

# ----------------------------------------------------------------------------
# Utility functions

sub _is_inlist {
    my $string = shift;
    return 0 unless defined $string;
    my $list = (scalar @_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : \@_;
     
    return 1 if grep {$string eq $_ } @$list;
    return 0;
}

sub _compare_list {
    my ($list1,$list2) = @_;

    return 0 unless ref($list1) eq 'ARRAY' && ref($list2) eq 'ARRAY';

    foreach my $element1 (@$list1) {
        next unless defined $element1;
        foreach my $element2 (@$list2) {
            next unless defined $element2;
            return 1 if    $element1 eq $element2;
        }
    } 
    
    return 0;
}

"Schmitt ~ Smith ~ Schmitz";