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


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Tie::Hash::Regex - Match hash keys using Regular Expressions
5              
6             =head1 SYNOPSIS
7              
8             use Tie::Hash::Regex;
9             my %h;
10              
11             tie %h, 'Tie::Hash::Regex';
12              
13             $h{key} = 'value';
14             $h{key2} = 'another value';
15             $h{stuff} = 'something else';
16              
17             print $h{key}; # prints 'value'
18             print $h{2}; # prints 'another value'
19             print $h{'^s'}; # prints 'something else'
20              
21             print tied(%h)->FETCH('k'); # prints 'value' and 'another value'
22              
23             delete $h{k}; # deletes $h{key} and $h{key2};
24              
25             or (new! improved!)
26              
27             my %h : Regex;
28              
29             =head1 DESCRIPTION
30              
31             Someone asked on Perlmonks if a hash could do fuzzy matches on keys - this
32             is the result.
33              
34             If there's no exact match on the key that you pass to the hash, then the
35             key is treated as a regex and the first matching key is returned. You can
36             force it to leap straight into the regex checking by passing a qr'ed
37             regex into the hash like this:
38              
39             my $val = $h{qr/key/};
40              
41             C and C also do regex matching. In the case of C
42             I values matching your regex key will be deleted from the hash.
43              
44             One slightly strange thing. Obviously if you give a hash a regex key, then
45             it's possible that more than one key will match (consider C<$h{qw/./}>).
46             It might be nice to be able to do stuff like:
47              
48             my @vals = $h{$pat};
49              
50             to get I matching values back. Unfortuately, Perl knows that a given
51             hash key can only ever return one value and so forces scalar context on
52             the C call when using the tied interface. You can get round this
53             using the slightly less readable:
54              
55             my @vals = tied(%h)->FETCH($pat);
56              
57             =head2 ATTRIBUTE INTERFACE
58              
59             From version 0.06, you can use attributes to define your hash as being
60             tied to Tie::Hash::Regex. You'll need to install the module
61             Attribute::Handlers. Simply declare your hash using the attribute
62             syntax:
63              
64             my %hash :Regex;
65              
66              
67             =cut
68              
69             package Tie::Hash::Regex;
70              
71 1     1   70320 use 5.006;
  1         12  
72 1     1   6 use strict;
  1         2  
  1         22  
73 1     1   4 use warnings;
  1         2  
  1         92  
74             our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
75              
76             require Exporter;
77             require Tie::Hash;
78 1     1   630 use Attribute::Handlers autotie => { "__CALLER__::Regex" => __PACKAGE__ };
  1         4960  
  1         7  
79              
80             @ISA = qw(Exporter Tie::StdHash);
81             @EXPORT = qw();
82             @EXPORT_OK =();
83              
84             $VERSION = 1.14;
85              
86             =head1 METHODS
87              
88             =head2 FETCH
89              
90             Get a value from the hash. If there isn't an exact match try a regex
91             match.
92              
93             =cut
94              
95             sub FETCH {
96 6     6   4275 my $self = shift;
97 6         10 my $key = shift;
98              
99 6         12 my $is_re = (ref $key eq 'Regexp');
100              
101 6 100 100     33 return $self->{$key} if !$is_re && exists $self->{$key};
102              
103 5 100       60 $key = qr/$key/ unless $is_re;
104              
105             # NOTE: wantarray will _never_ be true when FETCH is called
106             # using the standard hash semantics. I've put that piece
107             # of code in for people who are happy using syntax like:
108             # tied(%h)->FETCH(qr/$pat/);
109 5 100       18 if (wantarray) {
110 1         10 return @{$self}{ grep /$key/, keys %$self };
  1         7  
111             } else {
112 4   100     44 /$key/ and return $self->{$_} for keys %$self;
113             }
114              
115 1         7 return;
116             }
117              
118             =head2 EXISTS
119              
120             See if a key exists in the hash. If there isn't an exact match try a regex
121             match.
122              
123             =cut
124              
125             sub EXISTS {
126 4     4   572 my $self = shift;
127 4         13 my $key = shift;
128              
129 4         10 my $is_re = (ref $key eq 'Regexp');
130              
131 4 100 100     23 return 1 if !$is_re && exists $self->{$key};
132              
133 3 100       30 $key = qr/$key/ unless $is_re;
134              
135 3   100     35 /$key/ && return 1 for keys %$self;
136              
137 1         6 return;
138             }
139              
140             =head2 DELETE
141              
142             Delete a key from the hash. If there isn't an exact match try a regex
143             match.
144              
145             =cut
146              
147             sub DELETE {
148 3     3   1113 my $self = shift;
149 3         6 my $key = shift;
150              
151 3         17 my $is_re = (ref $key eq 'Regexp');
152              
153 3 100 100     17 return delete $self->{$key} if !$is_re && exists $self->{$key};
154              
155 2 100       17 $key = qr/$key/ unless $is_re;
156              
157 2         6 for (keys %$self) {
158 3 100       19 if (/$key/) {
159 2         7 delete $self->{$_};
160             }
161             }
162             }
163              
164             1;
165             __END__