Changing Hash Behaviour with tie
by Dave Cross
|
Pages: 1, 2, 3
Another Example: Tie::Hash::Regex
Let's look at another example. This module came about from a discussion on Perlmonks a couple of months ago. Someone asked whether it was possible to match hash keys approximately. I suggested that a hash that matched keys as regular expressions might solve their problem and wrote the first draft of this module. I'm grateful to Jeff Pinyan, who made some suggestions for improvements to the module.
In order to make this change to the behavior of the hash, we need to
override the behavior of the FETCH, EXISTS and DELETE methods.
Here's the FETCH method.
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;
/$key/ and return $self->{$_} for keys %$self;
return;
}
|
|
Knowing what we know about tied objects, this is pretty simple to follow.
We start by getting the reference to the tied object (which will be a hash
reference) and the required key. We then check to see whether the
key is a reference to a precompiled regular expression (which would have
been compiled with qr//. If the key isn't a regex, then we start
by checking whether the key exists in the hash. If it does, we return the
associated value. If the key isn't found, then we assume that it is a
regex to search for. At this point we compile the regex as if it isn't
already precompiled (this gives us a preforamnce boost as we could
potentially need to match the regex against all of the keys in the
hash). Finally, we check each key in the hash in turn against the regex
and if it matches, then we return the associated value. If there are no matches
we simply return.
At this point you may realize that it's possible for more than one key to
match a regex and you may suggest that it would be nice for FETCH to
return all matches as if it was called in scalar context. This is a nice
idea, but in current versions of Perl the syntax $hash{$key} always
calls FETCH in scalar context (and the syntax @hash{@keys} calls
FETCH once in scalar context for each element of @keys) so this
won't work. To get round this, you can use the slightly kludgey syntax
@vals = tied(%hash)-FETCH($pattern)> and the version of the module
on CPAN supports this.
The EXISTS method uses similar processing, but in this case we
return 1 if the key is found instead of the associated value.
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 %$key;
return;
}
The DELETE method is somewhat different. In this case, we can delete
all matching key/value pairs, which we do with the following code:
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->{$_};
}
}
}
I should point out that there is another similar module on CPAN called Tie::RegexpHash written by robert Rothenberg. Tie::RegexpHash actually does the opposite to Tie::Hash::Regex. When you store a value in it, the key is a regular expression and any time you look up a value with a key, you will get the value associated with the first regex key that matches your string. It's interesting to note that Tie::RegexpHash isn't based on Tie::StdHash and, as a result, contains a lot more code than Tie::Hash::Regex.
Another recent addition to CPAN is Tie::Hash::Approx, which was written by Briac Pilpré. This addresses a similar problem, but instead of using regex matching, it uses Jarkko Hietaniemi's String::Approx module.
Conclusion: Tie::Hash::Cannabinol
As a final example, here's something that isn't quite so useful. This
is a hash that forgets just about everything that you tell it. Its exists
function isn't exactly to be trusted either.
package Tie::Hash::Cannabinol;
use strict;
use vars qw(@ISA);
use Tie::Hash;
$VERSION = '0.01';
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $val) = @_;
return if rand > .75;
$self->{$key} = $val;
}
sub FETCH {
my ($self, $key) = @_;
return if rand > .75;
return $self->{rand keys %$self};
}
sub EXISTS {
return rand > .5;
}
As you can see, it's simple to make some radical alterations
to the behavior of Perl hashes using tie and the Tie::StdHash base
class. As I said at the start of the article, this often enables you to
create new ``objects'' without having to make the leap to full object
orientation in you programs.
And it isn't just hashes that you can do it for. The standard Perl distribution also comes with packages called Tie::StdArray, Tie::StdHandle and Tie::StdScalar.
Have fun with them.
