File Coverage

blib/lib/String/Approx.pm

Criterion	Covered	Total	%
statement	205	283	72.4
branch	125	188	66.4
condition	11	15	73.3
subroutine	18	26	69.2
pod	1	14	7.1
total	360	526	68.4

package String::Approx;

require v5.8.0;

$VERSION = '3.28';

use strict;
local $^W = 1;

use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);

@EXPORT_OK = qw(amatch asubstitute aindex aslice arindex
		adist adistr adistword adistrword);

bootstrap String::Approx $VERSION;

my $CACHE_MAX = 1000;	# high water mark
my $CACHE_PURGE = 0.75;	# purge this much of the least used
my $CACHE_N_PURGE;	# purge this many of the least used

sub cache_n_purge () {
    $CACHE_N_PURGE = $CACHE_MAX * $CACHE_PURGE;
    $CACHE_N_PURGE = 1 if $CACHE_N_PURGE < 1;
    return $CACHE_N_PURGE;
}

cache_n_purge();

sub cache_max (;$) {
    if (@_ == 0) {
	return $CACHE_MAX;
    } else {
	$CACHE_MAX = shift;
    }
    $CACHE_MAX = 0 if $CACHE_MAX < 0;
    cache_n_purge();
}

sub cache_purge (;$) {
    if (@_ == 0) {
	return $CACHE_PURGE;
    } else {
	$CACHE_PURGE = shift;
    }
    if ($CACHE_PURGE < 0) {
	$CACHE_PURGE = 0;
    } elsif ($CACHE_PURGE > 1) {
	$CACHE_PURGE = 1;
    }
    cache_n_purge();
}

my %_simple;
my %_simple_usage_count;

sub _cf_simple {
    my $P = shift;

    my @usage =
	sort { $_simple_usage_count{$a} <=> $_simple_usage_count{$b} }
             grep { $_ ne $P }
                  keys %_simple_usage_count;

    # Make room, delete the least used entries.
    $#usage = $CACHE_N_PURGE - 1;

    delete @_simple_usage_count{@usage};
    delete @_simple{@usage};
}

sub _simple {
    my $P = shift;

    my $_simple = new(__PACKAGE__, $P);

    if ($CACHE_MAX) {
	$_simple{$P} = $_simple unless exists $_simple{$P};

	$_simple_usage_count{$P}++;

	if (keys %_simple_usage_count > $CACHE_MAX) {
	    _cf_simple($P);
	}
    }

    return ( $_simple );
}

sub _parse_param {
    use integer;

    my ($n, @param) = @_;
    my %param;

    foreach (@param) {
        while ($_ ne '') {
	    s/^\s+//;
            if (s/^([IDS]\s*)?(\d+)(\s*%)?//) {
                my $k = defined $3 ? (($2-1) * $n) / 100 + ($2 ? 1 : 0) : $2;

		if (defined $1) {
		    $param{$1} = $k;
		} else {
		    $param{k}  = $k;
		}
	    } elsif (s/^initial_position\W+(\d+)\b//) {
		$param{'initial_position'} = $1;
	    } elsif (s/^final_position\W+(\d+)\b//) {
		$param{'final_position'} = $1;
	    } elsif (s/^position_range\W+(\d+)\b//) {
		$param{'position_range'} = $1;
	    } elsif (s/^minimal_distance\b//) {
		$param{'minimal_distance'} = 1;
            } elsif (s/^i//) {
                $param{ i } = 1;
            } elsif (s/^g//) {
                $param{ g } = 1;
            } elsif (s/^\?//) {
                $param{'?'} = 1;
            } else {
                warn "unknown parameter: '$_'\n";
                return;
            }
        }
    }

    return %param;
}

my %_param_key;
my %_parsed_param;

my %_complex;
my %_complex_usage_count;

sub _cf_complex {
    my $P = shift;

    my @usage =
	sort { $_complex_usage_count{$a} <=>
		   $_complex_usage_count{$b} }
             grep { $_ ne $P }
                  keys %_complex_usage_count;

    # Make room, delete the least used entries.
    $#usage = $CACHE_N_PURGE - 1;

    delete @_complex_usage_count{@usage};
    delete @_complex{@usage};
}

sub _complex {
    my ($P, @param) = @_;
    unshift @param, length $P;
    my $param = "@param";
    my $_param_key;
    my %param;
    my $complex;
    my $is_new;

    unless (exists $_param_key{$param}) {
	%param = _parse_param(@param);
	$_parsed_param{$param} = { %param };
	$_param_key{$param} = join(" ", %param);
    } else {
	%param = %{ $_parsed_param{$param} };
    }

    $_param_key = $_param_key{$param};

    if ($CACHE_MAX) {
	if (exists $_complex{$P}->{$_param_key}) {
	    $complex = $_complex{$P}->{$_param_key};
	}
    }

    unless (defined $complex) {
	if (exists $param{'k'}) {
	    $complex = new(__PACKAGE__, $P, $param{k});
	} else {
	    $complex = new(__PACKAGE__, $P);
	}
	$_complex{$P}->{$_param_key} = $complex if $CACHE_MAX;
	$is_new = 1;
    }

    if ($is_new) {
	$complex->set_greedy unless exists $param{'?'};

	$complex->set_insertions($param{'I'})
	    if exists $param{'I'};
	$complex->set_deletions($param{'D'})
	    if exists $param{'D'};
	$complex->set_substitutions($param{'S'})
	    if exists $param{'S'};

	$complex->set_caseignore_slice
	    if exists $param{'i'};

	$complex->set_text_initial_position($param{'initial_position'})
	    if exists $param{'initial_position'};

	$complex->set_text_final_position($param{'final_position'})
	    if exists $param{'final_position'};

	$complex->set_text_position_range($param{'position_range'})
	    if exists $param{'position_range'};

	$complex->set_minimal_distance($param{'minimal_distance'})
	    if exists $param{'minimal_distance'};
    }

    if ($CACHE_MAX) {
	$_complex_usage_count{$P}->{$_param_key}++;

	# If our cache overfloweth.
	if (scalar keys %_complex_usage_count > $CACHE_MAX) {
	    _cf_complex($P);
	}
    }

    return ( $complex, %param );
}

sub cache_disable {
    cache_max(0);
}

sub cache_flush_all {
    my $old_purge = cache_purge();
    cache_purge(1);
    _cf_simple('');
    _cf_complex('');
    cache_purge($old_purge);
}

sub amatch {
    my $P = shift;
    return 1 unless length $P;
    my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
		 _complex($P, @{ shift(@_) }) : _simple($P))[0];

    if (@_) {
        if (wantarray) {
            return grep { $a->match($_) } @_;
        } else {
            foreach (@_) {
                return 1 if $a->match($_);
            }
             return 0;
        }
    }
    if (defined $_) {
        if (wantarray) {
            return $a->match($_) ? $_ : undef;
        } else {
	    return 1 if $a->match($_);
        }
    }
    return $a->match($_) if defined $_;

    warn "amatch: \$_ is undefined: what are you matching?\n";
    return;
}

sub _find_substitute {
    my ($ri, $rs, $i, $s, $S, $rn) = @_;

    push @{ $ri }, $i;
    push @{ $rs }, $s;

    my $pre = substr($_, 0, $i);
    my $old = substr($_, $i, $s);
    my $suf = substr($_, $i + $s);
    my $new = $S;

    $new =~ s/\$\`/$pre/g;
    $new =~ s/\$\&/$old/g;
    $new =~ s/\$\'/$suf/g;

    push @{ $rn }, $new;
}

sub _do_substitute {
    my ($rn, $ri, $rs, $rS) = @_;

    my $d = 0;
    my $n = $_;

    foreach my $i (0..$#$rn) {
	substr($n, $ri->[$i] + $d, $rs->[$i]) = $rn->[$i];
	$d += length($rn->[$i]) - $rs->[$i];
    }

    push @{ $rS }, $n;
}

sub asubstitute {
    my $P = shift;
    my $S = shift;
    my ($a, %p) =
	(@_ && ref $_[0] eq 'ARRAY') ?
	    _complex($P, @{ shift(@_) }) : _simple($P);

    my ($i, $s, @i, @s, @n, @S);

    if (@_) {
	if (exists $p{ g }) {
	    foreach (@_) {
		@s = @i = @n = ();
		while (($i, $s) = $a->slice_next($_)) {
		    if (defined $i) {
			_find_substitute(\@i, \@s, $i, $s, $S, \@n);
		    }
		}
		_do_substitute(\@n, \@i, \@s, \@S) if @n;
	    }
	} else {
	    foreach (@_) {
		@s = @i = @n = ();
		($i, $s) = $a->slice($_);
		if (defined $i) {
		    _find_substitute(\@i, \@s, $i, $s, $S, \@n);
		    _do_substitute(\@n, \@i, \@s, \@S);
		}
	    }
	}
	return @S;
    } elsif (defined $_) {
	if (exists $p{ g }) {
	    while (($i, $s) = $a->slice_next($_)) {
		if (defined $i) {
		    _find_substitute(\@i, \@s, $i, $s, $S, \@n);
		}
	    }
	    _do_substitute(\@n, \@i, \@s, \@S) if @n;
	} else {
	    ($i, $s) = $a->slice($_);
	    if (defined $i) {
		_find_substitute(\@i, \@s, $i, $s, $S, \@n);
		_do_substitute(\@n, \@i, \@s, \@S);
	    }
	}
	return $_ = $n[0];
    } else {
	warn "asubstitute: \$_ is undefined: what are you substituting?\n";
        return;
    }
}

sub aindex {
    my $P = shift;
    return 0 unless length $P;
    my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
		 _complex($P, @{ shift(@_) }) : _simple($P))[0];

    $a->set_greedy; # The *first* match, thank you.

    if (@_) {
	if (wantarray) {
	    return map { $a->index($_) } @_;
	} else {
	    return $a->index($_[0]);
	}
    }
    return $a->index($_) if defined $_;

    warn "aindex: \$_ is undefined: what are you indexing?\n";
    return;
}

sub aslice {
    my $P = shift;
    return (0, 0) unless length $P;
    my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
		 _complex($P, @{ shift(@_) }) : _simple($P))[0];

    $a->set_greedy; # The *first* match, thank you.

    if (@_) {
	return map { [ $a->slice($_) ] } @_;
    }
    return $a->slice($_) if defined $_;

    warn "aslice: \$_ is undefined: what are you slicing?\n";
    return;
}

sub _adist {
    my $s0 = shift;
    my $s1 = shift;
    my ($aslice) = aslice($s0, ['minimal_distance', @_], $s1);
    my ($index, $size, $distance) = @$aslice;
    my ($l0, $l1) = map { length } ($s0, $s1);
    return $l0 <= $l1 ? $distance : -$distance;
}

sub adist {
    my $a0 = shift;
    my $a1 = shift;
    if (length($a0) == 0) {
      return length($a1);
    }
    if (length($a1) == 0) {
      return length($a0);
    }
    my @m = ref $_[0] eq 'ARRAY' ? @{shift()} : ();
    if (ref $a0 eq 'ARRAY') {
	if (ref $a1 eq 'ARRAY') {
	    return [ map {  adist($a0, $_, @m) } @{$a1} ];
	} else {
	    return [ map { _adist($_, $a1, @m) } @{$a0} ];
	}
    } elsif (ref $a1 eq 'ARRAY') {
	return     [ map { _adist($a0, $_, @m) } @{$a1} ];
    } else {
	if (wantarray) {
	    return map { _adist($a0, $_, @m) } ($a1, @_);
	} else {
	    return _adist($a0, $a1, @m);
	}
    }
}

sub adistr {
    my $a0 = shift;
    my $a1 = shift;
    my @m = ref $_[0] eq 'ARRAY' ? shift : ();
    if (ref $a0 eq 'ARRAY') {
	if (ref $a1 eq 'ARRAY') {
	    my $l0 = length();
	    return $l0 ? [ map { adist($a0, $_, @m) }
			  @{$a1} ] :
		         [ ];
	} else {
	    return [ map { my $l0 = length();
			   $l0 ? _adist($_, $a1, @m) / $l0 : undef
		     } @{$a0} ];
	}
    } elsif (ref $a1 eq 'ARRAY') {
	my $l0 = length($a0);
	return [] unless $l0;
	return     [ map { _adist($a0, $_, @m) / $l0 } @{$a1} ];
    } else {
	my $l0 = length($a0);
	if (wantarray) {
	    return map { $l0 ? _adist($a0, $_, @m) / $l0 : undef } ($a1, @_);
	} else {
	    return undef unless $l0;
	    return _adist($a0, $a1, @m) / $l0;
	}
    }
}

sub adistword {
    return adist($_[0], $_[1], ['position_range=0']);
}

sub adistrword {
    return adistr($_[0], $_[1], ['position_range=0']);
}

sub arindex {
    my $P = shift;
    my $l = length $P;
    return 0 unless $l;
    my $R = reverse $P;
    my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
		 _complex($R, @{ shift(@_) }) : _simple($R))[0];

    $a->set_greedy; # The *first* match, thank you.

    if (@_) {
	if (wantarray) {
	    return map {
		my $aindex = $a->index(scalar reverse());
		$aindex == -1 ? $aindex : (length($_) - $aindex - $l);
	    } @_;
	} else {
	    my $aindex = $a->index(scalar reverse $_[0]);
	    return $aindex == -1 ? $aindex : (length($_[0]) - $aindex - $l);
	}
    }
    if (defined $_) {
	my $aindex = $a->index(scalar reverse());
	return $aindex == -1 ? $aindex : (length($_) - $aindex - $l);
    }

    warn "arindex: \$_ is undefined: what are you indexing?\n";
    return;
}

1;
__END__