File Coverage

lib/String/Fuzzy.pm

Criterion	Covered	Total	%
statement	138	147	93.8
branch	76	128	59.3
condition	32	61	52.4
subroutine	21	21	100.0
pod	7	7	100.0
total	274	364	75.2

##----------------------------------------------------------------------------
## String Fuzzy - ~/lib/String/Fuzzy.pm
## Version v0.1.1
## Copyright(c) 2025 DEGUEST Pte. Ltd.
## Author: Jacques Deguest
## Created 2025/03/29
## Modified 2025/03/31
## All rights reserved
##
##
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package String::Fuzzy;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Exporter );
    use vars qw( @EXPORT_OK $VERSION );
    require overload;
    use Encode qw( encode_utf8 decode_utf8 is_utf8 );
    use List::Util qw( min max );
    use Scalar::Util qw( looks_like_number );
    use Text::Levenshtein::XS qw( distance );
    use Unicode::Normalize qw( NFD );
    our @EXPORT_OK = qw(
        extract_best
        extract_all
        fuzzy_substring_ratio
        partial_ratio
        ratio
        token_set_ratio
        token_sort_ratio
    );
    our $VERSION = 'v0.1.1';
};

use strict;
use warnings;

sub extract_all
{
    my( $query, $choices, %opts ) = @_;
    my $scorer = $opts{scorer} || \∶
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Handle undef query or choices
    return( [] ) if( !defined( $query ) || !defined( $choices ) || ref( $choices ) ne 'ARRAY' );

    return [
        sort { $b->[1] <=> $a->[1] }  # Sort by score descending
        map {
            my $score = $scorer->( $query, $_, normalize => $normalize );
            [$_, $score]
        } @$choices
    ];
}

sub extract_best
{
    my( $query, $choices, %opts ) = @_;
    my $scorer = $opts{scorer} || \∶
    my $limit = $opts{limit} || 1;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Handle undef query or choices
    return( undef ) if( !defined( $query ) || !defined( $choices ) || ref( $choices ) ne 'ARRAY' );

    my @results = map {
        my $score = $scorer->( $query, $choices->[$_], normalize => $normalize );
        [$choices->[$_], $score, $_]  # Include index
    } 0 .. $#$choices;

    @results = sort { $b->[1] <=> $a->[1] } @results;

    return( $limit == 1 ? $results[0] : [@results[0 .. $limit - 1]] );
}

sub fuzzy_substring_ratio
{
    my( $needle, $haystack, %opts ) = @_;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Validate references, allow stringifiable objects
    if( ref( $needle ) && !overload::Method( $needle, '""' ) )
    {
        die( "Needle must be a scalar or stringifiable object, not a reference" );
    }
    elsif( ref( $haystack ) && !overload::Method( $haystack, '""' ) )
    {
        die( "Haystack must be a scalar or stringifiable object, not a reference" );
    }

    my $str_needle = $normalize ? _normalize( defined( $needle ) ? "$needle" : $needle ) : ( defined( $needle ) ? "$needle" : $needle );
    my $str_haystack = $normalize ? _normalize( defined( $haystack ) ? "$haystack" : $haystack ) : ( defined( $haystack ) ? "$haystack" : $haystack );

    my $nlen = length( $str_needle );
    my $hlen = length( $str_haystack );
    return(0) if( $nlen == 0 || $hlen == 0 );

    my $max_score = 0;

    for my $window ( $nlen - 2 .. $nlen + 2 )
    {
        next if( $window < 3 || $window > $hlen );
        for my $i ( 0 .. $hlen - $window )
        {
            my $chunk = substr( $str_haystack, $i, $window );
            my $score = ratio( $str_needle, $chunk, normalize => 0 );  # Already normalized if needed
            $max_score = $score if( $score > $max_score );
        }
    }

    return( $max_score );
}

sub partial_ratio
{
    my( $s1, $s2, %opts ) = @_;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Validate references, allow stringifiable objects
    if( ref( $s1 ) && !overload::Method( $s1, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The first string is invalid." );
    }
    elsif( ref( $s2 ) && !overload::Method( $s2, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The second string is invalid." );
    }

    my $str1 = $normalize ? _normalize( defined( $s1 ) ? "$s1" : $s1 ) : ( defined( $s1 ) ? "$s1" : $s1 );
    my $str2 = $normalize ? _normalize( defined( $s2 ) ? "$s2" : $s2 ) : ( defined( $s2 ) ? "$s2" : $s2 );

    ( $str1, $str2 ) = ( $str2, $str1 ) if( length( $str1 ) > length( $str2 ) );
    return(0) if( length( $str1 ) == 0 );

    my $max_score = 0;
    my $s1_len = length( $str1 );
    my $s2_len = length( $str2 );

    # Check for full containment first
    if( index( $str2, $str1 ) != -1 )
    {
        return(100);
    }

    # Slide window of s1's length over s2, ensuring typo tolerance
    for my $i ( 0 .. $s2_len - $s1_len )
    {
        my $substr = substr( $str2, $i, $s1_len );
        my $score = ratio( $str1, $substr, normalize => $normalize );  # Use caller's normalize setting
        $max_score = max( $max_score, $score );  # Explicitly use max()
    }

    return( $max_score );
}

sub ratio
{
    my( $s1, $s2, %opts ) = @_;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Validate references, allow stringifiable objects
    if( ref( $s1 ) && !overload::Method( $s1, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The first string is invalid." );
    }
    elsif( ref( $s2 ) && !overload::Method( $s2, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The second string is invalid." );
    }

    my $str1 = $normalize ? _normalize( defined( $s1 ) ? "$s1" : $s1 ) : ( defined( $s1 ) ? "$s1" : $s1 );
    my $str2 = $normalize ? _normalize( defined( $s2 ) ? "$s2" : $s2 ) : ( defined( $s2 ) ? "$s2" : $s2 );

    return(100) if( $str1 eq $str2 );
    return(0) if( !length( $str1 // '' ) || !length( $str2 // '' ) );

    my $distance = distance( $str1, $str2 );
    my $length = $normalize
        ? max( length( $str1 ), length( $str2 ) )
        : max( length( is_utf8( $str1 ) ? encode_utf8( $str1 ) : $str1 ), length( is_utf8( $str2 ) ? encode_utf8( $str2 ) : $str2 ) );

    return( ( 1 - $distance / $length ) * 100 );  # Keep as float
}

sub token_set_ratio
{
    my( $s1, $s2, %opts ) = @_;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Validate references, allow stringifiable objects
    if( ref( $s1 ) && !overload::Method( $s1, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The first string is invalid." );
    }
    elsif( ref( $s2 ) && !overload::Method( $s2, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The second string is invalid." );
    }

    my $str1 = $normalize ? _normalize( defined( $s1 ) ? "$s1" : $s1 ) : ( defined( $s1 ) ? "$s1" : $s1 );
    my $str2 = $normalize ? _normalize( defined( $s2 ) ? "$s2" : $s2 ) : ( defined( $s2 ) ? "$s2" : $s2 );

    my @tokens1 = split( /\s+/, $str1 );
    my @tokens2 = split( /\s+/, $str2 );

    my %count;
    $count{ $_ }++ for( @tokens1, @tokens2 );
    my @intersection = grep { $count{$_} > 1 } keys( %count );
    my @left  = grep { !$count{ $_ } || $count{ $_ } == 1 } @tokens1;
    my @right = grep { !$count{ $_ } || $count{ $_ } == 1 } @tokens2;

    my $sorted_common  = join( ' ', sort( @intersection ) );
    my $combined_left  = join( ' ', sort( @intersection, @left ) );
    my $combined_right = join( ' ', sort( @intersection, @right ) );

    return max(
        ratio( $sorted_common, $combined_left, normalize => 0 ),
        ratio( $sorted_common, $combined_right, normalize => 0 ),
        ratio( $combined_left, $combined_right, normalize => 0 )
    );
}

sub token_sort_ratio
{
    my( $s1, $s2, %opts ) = @_;
    my $normalize = exists( $opts{normalize} ) ? $opts{normalize} : 1;

    # Validate references, allow stringifiable objects
    if( ref( $s1 ) && !overload::Method( $s1, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The first string is invalid." );
    }
    elsif( ref( $s2 ) && !overload::Method( $s2, '""' ) )
    {
        die( "Both input strings must be scalars or stringifiable objects, not references. The second string is invalid." );
    }

    my $str1 = $normalize ? _normalize( defined( $s1 ) ? "$s1" : $s1 ) : ( defined( $s1 ) ? "$s1" : $s1 );
    my $str2 = $normalize ? _normalize( defined( $s2 ) ? "$s2" : $s2 ) : ( defined( $s2 ) ? "$s2" : $s2 );

    my $sorted1 = join( ' ', sort( split( /\s+/, $str1 ) ) );
    my $sorted2 = join( ' ', sort( split( /\s+/, $str2 ) ) );
    return( ratio( $sorted1, $sorted2, normalize => 0 ) );
}

sub _normalize
{
    my( $str ) = @_;
    return( '' ) unless( defined( $str ) );
    $str = lc( $str );
    $str = NFD( $str );
    $str =~ s/\pM+//g;              # Remove diacritics
    $str =~ s/[^\p{L}\p{Nd}\s]//g;  # Remove punctuation/symbols
    $str =~ s/\s+/ /g;              # Normalize whitespace
    $str =~ s/^\s+|\s+$//g;         # Trim
    return( $str );
}

1;
# NOTE: POD
__END__