File Coverage

blib/lib/Tie/Hash/Regex.pm

Criterion	Covered	Total	%
statement	36	36	100.0
branch	16	16	100.0
condition	13	13	100.0
subroutine	7	7	100.0
pod			n/a
total	72	72	100.0

=head1 NAME

Tie::Hash::Regex - Match hash keys using Regular Expressions

=head1 SYNOPSIS

  use Tie::Hash::Regex;
  my %h;

  tie %h, 'Tie::Hash::Regex';

  $h{key}   = 'value';
  $h{key2}  = 'another value';
  $h{stuff} = 'something else';

  print $h{key};  # prints 'value'
  print $h{2};    # prints 'another value'
  print $h{'^s'}; # prints 'something else'

  print tied(%h)->FETCH('k'); # prints 'value' and 'another value'

  delete $h{k};   # deletes $h{key} and $h{key2};

or (new! improved!)

  my %h : Regex;

=head1 DESCRIPTION

Someone asked on Perlmonks if a hash could do fuzzy matches on keys - this
is the result.

If there's no exact match on the key that you pass to the hash, then the
key is treated as a regex and the first matching key is returned. You can
force it to leap straight into the regex checking by passing a qr'ed
regex into the hash like this:

  my $val = $h{qr/key/};

C and C also do regex matching. In the case of C
I values matching your regex key will be deleted from the hash.

One slightly strange thing. Obviously if you give a hash a regex key, then
it's possible that more than one key will match (consider C<$h{qw/./}>).
It might be nice to be able to do stuff like:

  my @vals = $h{$pat};

to get I matching values back. Unfortuately, Perl knows that a given
hash key can only ever return one value and so forces scalar context on
the C call when using the tied interface. You can get round this
using the slightly less readable:

  my @vals = tied(%h)->FETCH($pat);

=head2 ATTRIBUTE INTERFACE

From version 0.06, you can use attributes to define your hash as being
tied to Tie::Hash::Regex. You'll need to install the module
Attribute::Handlers. Simply declare your hash using the attribute
syntax:

    my %hash :Regex;


=cut

package Tie::Hash::Regex;

use 5.006;
use strict;
use warnings;
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);

require Exporter;
require Tie::Hash;
use Attribute::Handlers autotie => { "__CALLER__::Regex" => __PACKAGE__ };

@ISA = qw(Exporter Tie::StdHash);
@EXPORT = qw();
@EXPORT_OK =();

$VERSION = 1.14;

=head1 METHODS

=head2 FETCH

Get a value from the hash. If there isn't an exact match try a regex
match.

=cut

sub FETCH {
  my $self = shift;
  my $key = shift;

  my $is_re = (ref $key eq 'Regexp');

  return $self->{$key} if !$is_re && exists $self->{$key};

  $key = qr/$key/ unless $is_re;

  # NOTE: wantarray will _never_ be true when FETCH is called
  #       using the standard hash semantics. I've put that piece
  #       of code in for people who are happy using syntax like:
  #       tied(%h)->FETCH(qr/$pat/);
  if (wantarray) {
    return @{$self}{ grep /$key/, keys %$self };
  } else {
    /$key/ and return $self->{$_} for keys %$self;
  }

  return;
}

=head2 EXISTS

See if a key exists in the hash. If there isn't an exact match try a regex
match.

=cut

sub EXISTS {
  my $self = shift;
  my $key = shift;

  my $is_re = (ref $key eq 'Regexp');

  return 1 if !$is_re && exists $self->{$key};

  $key = qr/$key/ unless $is_re;

  /$key/ && return 1 for keys %$self;

  return;
}

=head2 DELETE

Delete a key from the hash. If there isn't an exact match try a regex
match.

=cut

sub DELETE {
  my $self = shift;
  my $key = shift;

  my $is_re = (ref $key eq 'Regexp');

  return delete $self->{$key} if !$is_re && exists $self->{$key};

  $key = qr/$key/ unless $is_re;

  for (keys %$self) {
    if (/$key/) {
      delete $self->{$_};
    }
  }
}

1;
__END__