Category: | Tied Variables |
Author/Contact Info | Briac Pilpré - OeufMayo- briac(at)pilpre(dot)com |
Description: | If you use davorg's Tie::Hash::Regex on a daily basis, you may find this module useful too. It uses String::Approx to make approximative match on hash keys. Note that you may want to use Pod::Tests, to be able to run the inline tests. And it's a very convenient module too. |
package Tie::Hash::Approx; use strict; use vars qw($VERSION @ISA); require Exporter; require Tie::Hash; use String::Approx('amatch'); @ISA = qw(Exporter Tie::StdHash); $VERSION = '0.01'; =begin testing use Tie::Hash::Approx; my %hash; my $x = tie %hash, 'Tie::Hash::Approx'; ok( ref $x eq 'Tie::Hash::Approx', "tie'ing hash to Tie::Hash::Appro +x"); =end testing =cut sub FETCH { my $this = shift; my $key = shift; return undef unless %{$this}; # return if the hash is empty # We return immediatly if an exact match is found return $this->{$key} if exists $this->{$key}; # Otherwise, the fuzzy search kicks in my @results = amatch( $key, keys( %{$this} ) ); # wantarray doesn't work on tied hash, unless # you're using a "tied(%hash)->FETCH('foo');" # construct if (wantarray) { return @{$this}{@results}; } else { return $this->{ $results[0] }; } } =begin testing %hash = ( key => 'value', kay => 'another value', stuff => 'yet another stuff', ); ok( $hash{key} eq 'value', 'exact match' ); ok( $hash{staff} eq 'yet another stuff', 'approx match' ); =end testing =begin testing @res{ tied(%hash)->FETCH('koy') }++; ok( exists($res{'value'}) && exists($res{'another value'}), 'wantarr +ay approx match' ); =end testing =cut sub EXISTS { my $this = shift; my $key = shift; return undef unless %{$this}; return 1 if exists $this->{$key}; return if amatch( $key, keys( %{$this} ) ); } =begin testing ok( exists($hash{'key'}), 'exists exact match' ); ok( exists($hash{'staff'}), 'exists approx match' ); ok( !exists($hash{''}), 'exists empty match' ); =end testing =cut sub DELETE { my $this = shift; my $key = shift; return delete $this->{$key} if exists $this->{$key}; my @results = amatch( $key, keys( %{$this} ) ); # This will delete *all* the keys matching! delete @{$this}{ @results }; } =begin testing delete $hash{koy}; ok( !exists($hash{'key'}) && !exists($hash{'kay'}), 'deleting several + approx matches'); delete $hash{staff}; ok( !exists($hash{'staff'}), 'deleting approx match'); =end testing =cut 1; __END__ =head1 NAME Tie::Hash::Approx - Approximative match of hash keys using String::App +rox =head1 SYNOPSIS use Tie::Hash::Approx; my %hash; tie %hash, 'Tie::Hash::Approx'; %hash = ( key => 'value', kay => 'another value', stuff => 'yet another stuff', ); print $hash{'key'}; # prints 'value' print $hash{'koy'}; # prints 'another value' or 'value' print $hash{'staff'}; # prints 'yet another stuff' print tied(%hash)->FETCH('koy'); # prints 'value' and 'another value +' delete $hash{kee}; # deletes $h{key} and $h{kay} =head1 TODO Add the possibility of configuring the 'fuzziness' of the match (cf. the modifiers option in String::Approx). =head1 AUTHOR Briac Pilpre <briac @ pilpre . com > Thanks to Dave Cross for making Tie::Hash::Regex in the first place! =head1 SEE ALSO perl(1). perltie(1). Tie::Hash. String::Approx =cut |
Back to
Code Catacombs