File Coverage

blib/lib/Tie/Hash/Regex.pm

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

line	stmt	bran	cond	sub	time	code
1						# $Id: Regex.pm 15 2006-06-01 18:50:38Z dave $
2
3						=head1 NAME
4
5						Tie::Hash::Regex - Match hash keys using Regular Expressions
6
7						=head1 SYNOPSIS
8
9						use Tie::Hash::Regex;
10						my %h;
11
12						tie %h, 'Tie::Hash::Regex';
13
14						$h{key} = 'value';
15						$h{key2} = 'another value';
16						$h{stuff} = 'something else';
17
18						print $h{key}; # prints 'value'
19						print $h{2}; # prints 'another value'
20						print $h{'^s'}; # prints 'something else'
21
22						print tied(%h)->FETCH(k); # prints 'value' and 'another value'
23
24						delete $h{k}; # deletes $h{key} and $h{key2};
25
26						or (new! improved!)
27
28						my $h : Regex;
29
30						=head1 DESCRIPTION
31
32						Someone asked on Perlmonks if a hash could do fuzzy matches on keys - this
33						is the result.
34
35						If there's no exact match on the key that you pass to the hash, then the
36						key is treated as a regex and the first matching key is returned. You can
37						force it to leap straight into the regex checking by passing a qr'ed
38						regex into the hash like this:
39
40						my $val = $h{qr/key/};
41
42						C<exists> and C<delete> also do regex matching. In the case of C<delete>
43						I<all> vlaues matching your regex key will be deleted from the hash.
44
45						One slightly strange thing. Obviously if you give a hash a regex key, then
46						it's possible that more than one key will match (consider c<$h{qw/./}>).
47						It might be nice to be able to do stuff like:
48
49						my @vals = $h{$pat};
50
51						to get I<all> matching values back. Unfortuately, Perl knows that a given
52						hash key can only ever return one value and so forces scalar context on
53						the C<FETCH> call when using the tied interface. You can get round this
54						using the slightly less readable:
55
56						my @vals = tied(%h)->FETCH($pat);
57
58						=head2 ATTRIBUTE INTERFACE
59
60						From version 0.06, you can use attributes to define your hash as being tied
61						to Tie::Hash::Regex. You'll need to install the module Attribute::Handlers.
62
63						=cut
64
65						package Tie::Hash::Regex;
66
67	2			2	129773	use 5.006;
	2				5
	2				30
68	2			2	6	use strict;
	2				2
	2				27
69	2			2	4	use warnings;
	2				4
	2				98
70						our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
71
72						require Exporter;
73						require Tie::Hash;
74	2			2	433	use Attribute::Handlers autotie => { "__CALLER__::Regex" => __PACKAGE__ };
	2				5218
	2				14
75
76						@ISA = qw(Exporter Tie::StdHash);
77						@EXPORT = qw();
78						@EXPORT_OK =();
79
80						$VERSION = sprintf "%d", '$Revision: 15 $ ' =~ /(\d+)/;
81
82						=head1 METHODS
83
84						=head2 FETCH
85
86						Get a value from the hash. If there isn't an exact match try a regex
87						match.
88
89						=cut
90
91						sub FETCH {
92	6			6	91354	my $self = shift;
93	6				7	my $key = shift;
94
95	6				7	my $is_re = (ref $key eq 'Regexp');
96
97	6	100	100		35	return $self->{$key} if !$is_re && exists $self->{$key};
98
99	5	100			37	$key = qr/$key/ unless $is_re;
100
101						# NOTE: wantarray will _never_ be true when FETCH is called
102						# using the standard hash semantics. I've put that piece
103						# of code in for people who are happy using syntax like:
104						# tied(%h)->FETCH(qr/$pat/);
105	5	100			9	if (wantarray) {
106	1				4	return @{$self}{ grep /$key/, keys %$self };
	1				6
107						} else {
108	4		100		2	/$key/ and return $self->{$_} for keys %$self;
	4				42
109						}
110
111	1				8	return;
112						}
113
114						=head2 EXISTS
115
116						See if a key exists in the hash. If there isn't an exact match try a regex
117						match.
118
119						=cut
120
121						sub EXISTS {
122	4			4	190	my $self = shift;
123	4				5	my $key = shift;
124
125	4				4	my $is_re = (ref $key eq 'Regexp');
126
127	4	100	100		27	return 1 if !$is_re && exists $self->{$key};
128
129	3	100			16	$key = qr/$key/ unless $is_re;
130
131	3		100		3	/$key/ && return 1 for keys %$self;
	3				24
132
133	1				6	return;
134						}
135
136						=head2 DELETE
137
138						Delete a key from the hash. If there isn't an exact match try a regex
139						match.
140
141						=cut
142
143						sub DELETE {
144	3			3	344	my $self = shift;
145	3				3	my $key = shift;
146
147	3				5	my $is_re = (ref $key eq 'Regexp');
148
149	3	100	100		22	return delete $self->{$key} if !$is_re && exists $self->{$key};
150
151	2	100			9	$key = qr/$key/ unless $is_re;
152
153	2				3	for (keys %$self) {
154	3	100			13	if (/$key/) {
155	2				7	delete $self->{$_};
156						}
157						}
158						}
159
160						1;
161						__END__
162
163
164						=head1 AUTHOR
165
166						Dave Cross <dave@mag-sol.com>
167
168						Thanks to the Perlmonks <http://www.perlmonks.org> for the original idea
169						and to Jeff "japhy" Pinyan for some useful code suggestions.
170
171						=head1 COPYRIGHT
172
173						Copyright (C) 2001-8, Magnum Solutions Ltd. All Rights Reserved.
174
175						=head1 LICENSE
176
177						This script is free software; you can redistribute it and/or
178						modify it under the same terms as Perl itself.
179
180						=head1 SEE ALSO
181
182						perl(1).
183
184						perltie(1).
185
186						Tie::RegexpHash(1)
187
188						=cut
189