File Coverage

blib/lib/Tie/Hash/MultiValue.pm
Criterion Covered Total %
statement 60 60 100.0
branch 16 16 100.0
condition 4 6 66.6
subroutine 13 13 100.0
pod 3 3 100.0
total 96 98 97.9


line stmt bran cond sub pod time code
1             package Tie::Hash::MultiValue;
2 6     6   267861 use strict;
  6         37  
  6         111  
3 6     6   2101 use Tie::Hash;
  6         4000  
  6         204  
4             @Tie::Hash::MultiValue::ISA = qw(Tie::ExtraHash);
5              
6             BEGIN {
7 6     6   27 use vars qw ($VERSION);
  6         8  
  6         199  
8 6     6   3064 $VERSION = 1.03;
9             }
10              
11             =head1 NAME
12              
13             Tie::Hash::MultiValue - store multiple values per key
14              
15             =head1 SYNOPSIS
16              
17             use Tie::Hash::MultiValue;
18             my $controller = tie %hash, 'Tie::Hash::MultiValue';
19             $hash{'foo'} = 'one';
20             $hash{'bar'} = 'two';
21             $hash{'bar'} = 'three';
22              
23             # Fetch the values as references to arrays.
24             $controller->refs;
25             my @values = @{$hash{'foo'}}; # @values = ('one');
26             my @more = @{$hash{'bar'}}; # @more = ('two', 'three');
27             my @nothing = @{$hash{'baz'}}; # empty list if nothing there
28              
29             # You can tie an anonymous hash as well.
30             my $hashref = {};
31             tie %$hashref, 'Tie::Hash::MultiValue';
32             $hashref->{'sample'} = 'one';
33             $hashref->{'sample'} = 'two';
34             # $hashref->{'sample'} now contains ['one','two']
35              
36             # Iterate over the items stored under a key.
37             $controller->iterators;
38             while(my $value = $hash{bar}) {
39             print "bar: $value\n";
40             }
41             # prints
42             # bar: two
43             # bar: three
44              
45             =head1 DESCRIPTION
46              
47             C allows you to have hashes which store their values
48             in anonymous arrays, appending any new value to the already-existing ones.
49              
50             This means that you can store as many items as you like under a single key,
51             and access them all at once by accessing the value stored under the key.
52              
53             =head1 USAGE
54              
55             See the synopsis for a typical usage.
56              
57             =head1 BUGS
58              
59             None currently known.
60              
61             =head1 SUPPORT
62              
63             Contact the author for support.
64              
65             =head1 AUTHOR
66              
67             Joe McMahon
68             CPAN ID: MCMAHON
69             mcmahon@ibiblio.org
70             http://ibiblio.org/mcmahon
71              
72             =head1 COPYRIGHT
73              
74             This program is free software; you can redistribute
75             it and/or modify it under the same terms as Perl itself.
76              
77             The full text of the license can be found in the
78             LICENSE file included with this module.
79              
80              
81             =head1 SEE ALSO
82              
83             Tie::Hash, perl(1), Perl Cookbook (1st version) recipe 13.15, program 13-5.
84              
85             =head1 METHODS
86              
87             This class is a subclass of C; it needs to override the
88             C method to save the instance data (in $self->[1]), and the C
89             method to actually save the values in an anonymous array.
90              
91             =head2 TIEHASH
92              
93             If the 'unique' argument is supplied, we check to see if it supplies a
94             subroutine reference to be used to compare items. If it does, we store that
95             reference in the object describing this tie; if not, we supply a function
96             which simply uses 'eq' to test for equality.
97              
98             =head3 The 'unique' function
99              
100             This funtion will receive two scalar arguments. No assumption is made about
101             whether or not either argument is defined, nor whether these are simple
102             scalars or references. You can make any of these assumptions if you choose,
103             but you are responsible for checking your input.
104              
105             You can perform whatever tests you like in your routine; you should return
106             a true value if the arguments are determined to be equal, and a false one
107             if they are not.
108              
109             =cut
110              
111             sub TIEHASH {
112 6     6   311 my $class = shift;
113 6         13 my $self = [{},{}];
114 6         8 bless $self, $class;
115              
116 6 100       24 push @_, undef if @_ % 2 == 1;
117              
118 6         14 $self->refs;
119              
120              
121 6         11 my %args = @_;
122 6 100       12 if (exists $args{'unique'}) {
123 2 100 66     8 if (defined $args{'unique'} and ref $args{'unique'} eq 'CODE') {
124 1         2 $self->[1]->{Unique} = $args{'unique'};
125             }
126             else {
127             $self->[1]->{Unique} = sub {
128 2     2   3 my ($foo, $bar) = @_;
129 2         13 $foo eq $bar;
130 1         4 };
131             }
132             }
133 6         14 return $self;
134             }
135              
136             =head2 STORE
137              
138             Push the value(s) supplied onto the list of values stored here. The anonymous
139             array is created automatically if it doesn't yet exist.
140              
141             If the 'unique' argument was supplied at the time the hash was tied, we will
142             use the associated function (either yours, if you supplied one; or ours, if
143             you didn't) and only add the item or items that are not present.
144              
145             =cut
146              
147             sub STORE {
148 18     18   11591 my($self, $key, @values) = @_;
149              
150 18 100       44 if ($self->[1]->{Unique}) {
151             # The unique test is defined; check the incoming values to see if
152             # any of them are unique
153 9         9 local $_;
154 9         12 foreach my $item (@values) {
155 9 100       9 next if grep {$self->[1]->{Unique}->($_, $item)} @{$self->[0]->{$key}};
  6         13  
  9         21  
156 7         17 push @{$self->[0]->{$key}}, $item;
  7         20  
157             }
158             }
159             else {
160 9         9 push @{$self->[0]->{$key}}, @values;
  9         27  
161             }
162             }
163              
164             =head2 FETCH
165              
166             Fetches the current value(s) for a key, depending on the current mode
167             we're in.
168              
169             =over
170              
171             =item * 'refs' mode
172              
173             Always returns an anonymous array containing the values stored under this key,
174             or an empty anonymous array if there are none.
175              
176             =item * 'iterators' mode
177              
178             If there is a single entry, acts just like a normal hash fetch. If there are
179             multiple entries for a key, we automatically iterate over the items stored
180             under the key, returning undef when the last item under that key has been
181             fetched.
182              
183             Storing more elements into a key while you're iterating over it will result
184             in the new elements being returned at the end of the list. If you've turned
185             on 'unique', remember that they won't be stored if they're already in the
186             value list for the key.
187              
188             =over
189              
190             B: If you store undef in your hash, and then store other values, the
191             iterator will, when it sees your undef, return it as a normal value. This
192             means that you won't be able to tell whether that's I undef, or the
193             'I have no more data here' undef. Using 'list' or 'refs' mode is strongly
194             suggested if you need to store data that may include undefs.
195              
196             =back
197              
198             Note that every key has its own iterator, so you can mix accesses across keys
199             and still get all the values:
200              
201             my $controller = tie %hash, 'Tie::Hash::MultiValue';
202             $controller->iterators;
203             $hash{x} = $_ for qw(a b c);
204             $hash{y} = $_ for qw(d e f);
205             while ( my($x, $y) = ($hash{x}, $hash{y}) {
206             # gets (a,d) (b,e) (c,f)
207             }
208              
209             =back
210              
211             =cut
212              
213             sub FETCH {
214 42     42   19823 my($self) = @_;
215             { 'refs' => \&_FETCH_refs,
216             'iterators' => \&_FETCH_iters,
217 42         140 }->{ $self->[1]->{mode} }->(@_);
218             }
219              
220             sub _FETCH_refs {
221 33     33   50 my($self, $key) = @_;
222 33         81 return $self->[0]->{$key};
223             }
224              
225             sub _FETCH_iters {
226 9     9   16 my($self, $key) = @_;
227             # First, the simplest case. If we're fetching a key that doesn't exist,
228             # just return undef, and don't bother iterating at all.
229 9 100       20 return undef unless exists $self->[0]->{$key};
230              
231             # Regular fetch in scalar context. If we are not yet
232             # iterating, set up iteration over this key.
233 7 100 66     23 if (! $self->[1]->{iterators} or ! $self->[1]->{iterators}->{$key}) {
234 3         5 $self->[1]->{iterators}->{$key}->{iterator_index} = 0;
235 3         4 $self->[1]->{iterators}->{$key}->{iterating_over} = $key;
236             }
237             # Iterator either just set up or already running.
238             # Fetch the current entry for this key and bump the iterator
239             # for next time. If we're out of entries, return an undef
240             # and stop the iterator. We've already checked to see if there
241             # is anything under this key, so the deref is safe.
242 7         6 my $highest_index = @{ $self->[0]->{$key} } - 1;
  7         26  
243 7         8 my $current_index = $self->[1]->{iterators}->{$key}->{iterator_index};
244 7 100       11 if ($current_index > $highest_index) {
245             # Out of elements (or there are none).
246 3         5 $self->[1]->{iterators}->{$key} = undef;
247 3         8 return undef;
248             }
249             else {
250             # Return current value after bumping the iterator.
251 4         6 $self->[1]->{iterators}->{$key}->{iterator_index} += 1;
252 4         12 return $self->[0]->{$key}->[$current_index];
253             }
254             }
255              
256             =head2 iterators
257              
258             Called on the object returned from tie(). Tells FETCH to return elements
259             one at a time each time the key is accessed until no more element remain.
260              
261             =cut
262              
263             sub iterators {
264 1     1 1 318 my($self) = @_;
265 1         2 $self->[1]->{mode} = 'iterators';
266 1         2 $self->[1]->{iterators} = {};
267 1         1 return;
268             }
269              
270             =head2 refs
271              
272             Tells FETCH to always return the reference associated with a key. (This allows
273             you to, for instance, replace all of the values at once with different ones.)
274              
275             =cut
276              
277             sub refs {
278 6     6 1 10 my($self) = @_;
279 6         25 $self->[1]->{mode} = 'refs';
280 6         11 $self->[1]->{iterators} = {};
281 6         6 return;
282             }
283              
284             =head2 mode
285              
286             Tells you what mode you're currently in. Does I let you change it!
287              
288             =cut
289              
290             sub mode {
291 2     2 1 347 return $_[0]->[1]->{mode};
292             }
293              
294             1; #this line is important and will help the module return a true value
295             __END__