Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery


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

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

=end testing


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


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


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




=head1 NAME

Tie::Hash::Approx - Approximative match of hash keys using String::App


  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

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://105645]
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (3)
As of 2018-06-23 10:45 GMT
Find Nodes?
    Voting Booth?
    Should cpanminus be part of the standard Perl release?

    Results (125 votes). Check out past polls.