Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister


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]
[Discipulus]: chickenman do you know which kind of configuration file do you have? it is some standard?
[chickenman]: Thank you, I am looking for enlightenment! ;)
[chickenman]: Unfortunatly no standard, Its the Output of some command

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (5)
As of 2018-02-20 08:13 GMT
Find Nodes?
    Voting Booth?
    When it is dark outside I am happiest to see ...

    Results (268 votes). Check out past polls.