Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Tie::Hash::Approx

by OeufMayo (Curate)
on Aug 17, 2001 at 14:31 UTC ( #105645=sourcecode: print w/ replies, xml ) Need Help??

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

Comment on Tie::Hash::Approx
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://105645]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (4)
As of 2015-07-04 07:54 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (58 votes), past polls