File Coverage

lib/Tie/ListKeyedHash.pm
Criterion Covered Total %
statement 186 200 93.0
branch 142 142 100.0
condition n/a
subroutine 19 20 95.0
pod 6 6 100.0
total 353 368 95.9


line stmt bran cond sub pod time code
1             package Tie::ListKeyedHash;
2              
3 1     1   70407 use strict;
  1         2  
  1         30  
4 1     1   5 use warnings;
  1         1  
  1         34  
5              
6             BEGIN {
7 1     1   656 $Tie::ListKeyedHash::VERSION = "1.03";
8             }
9              
10             my $func_table = {}; # storage for the anon CODE refs used for hash lookups
11              
12             ####
13              
14             sub new {
15 13     13 1 1604 my $proto = shift;
16 13         16 my $package = __PACKAGE__;
17 13         14 my $class;
18 13 100       26 if (ref($proto)) {
    100          
19 1         2 $class = ref($proto);
20             } elsif ($proto) {
21 9         10 $class = $proto;
22             } else {
23 3         4 $class = $package;
24             }
25 13         12 my $self;
26 13 100       23 if (1 == @_) {
27 2         4 $self = shift;
28              
29             } else {
30 11         12 $self = {};
31             }
32 13         22 bless $self,$class;
33              
34 12 100       23 if (0 < @_) {
35 1         7 require Carp;
36 1         259 Carp::confess($package . '::new() - Unexpected parameters passed');
37             }
38              
39 11         18 return $self;
40             }
41              
42             ####
43              
44             sub TIEHASH {
45 2     2   331 return new(@_);
46             }
47              
48             ####
49              
50             sub STORE {
51 19     19   215 my $self = shift;
52              
53 19         27 my ($key,$value) = @_;
54 19 100       35 if (not ref $key) {
55 1         14 $key = [split(/$;/,$key)];
56             }
57 19         49 return $self->put($key,$value);
58             }
59              
60             ####
61              
62             sub FETCH {
63 19     19   89 my $self = shift;
64              
65 19         35 my ($key) = @_;
66 19 100       30 if (not ref $key) {
67 1         9 $key = [split(/$;/,$key)];
68             }
69 19         33 return $self->get($key);
70             }
71              
72             ####
73              
74             sub DELETE {
75 19     19   203 my $self = shift;
76            
77 19         27 my ($key) = @_;
78 19 100       32 if (not ref $key) {
79 1         7 $key = [split(/$;/,$key)];
80             }
81 19         38 return $self->delete($key);
82             }
83              
84             ####
85              
86             sub CLEAR {
87 1     1   8 my $self = shift;
88              
89 1         3 return $self->clear;
90             }
91              
92             ####
93              
94             sub EXISTS {
95 76     76   339 my $self = shift;
96              
97 76         102 my ($key) = @_;
98 76 100       115 if (not ref $key) {
99 2         23 $key = [split(/$;/,$key)];
100             }
101              
102 76         105 return $self->exists($key);
103             }
104              
105             ####
106              
107             sub FIRSTKEY {
108 2     2   15 my $self = shift;
109            
110 2         2 my $a = keys %{$self}; # Resets the 'each' to the start
  2         4  
111 2         5 my $key = scalar each %{$self};
  2         3  
112 2 100       8 return if (not defined $key);
113 1         4 return [$key];
114             }
115              
116             ####
117              
118             sub NEXTKEY {
119 19     19   21 my $self = shift;
120              
121 19         20 my ($last_key) = @_;
122 19         18 my $key = scalar each %{$self};
  19         23  
123 19 100       31 return if (not defined $key);
124 18         35 return [$key];
125             }
126              
127             ####
128              
129             sub clear {
130 2     2 1 6 my ($self) = shift;
131              
132 2         30 %$self = ();
133             }
134              
135             ####
136              
137             sub exists {
138 153     153 1 430 my ($self) = shift;
139              
140 153         167 my ($data_ref) = @_;
141              
142 153         158 my @data = eval { @$data_ref; };
  153         249  
143 153 100       214 if ($@) {
144 1         4 require Carp;
145 1         75 Carp::confess("bad key passed to exists");
146             }
147              
148             # Its _OK_ if the hash element doesn't exist
149 1     1   8 no warnings;
  1         2  
  1         538  
150              
151 152 100       336 if ($#data == 0) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
152 88         181 return CORE::exists $$self{$data[0]};
153             } elsif ($#data == 1) {
154 12         34 return CORE::exists $$self{$data[0]}{$data[1]};
155             } elsif ($#data > 12) {
156 8         14 my $anon_sub = $func_table->{-func_index}->{-exists}->[$#data];
157 8 100       16 unless (defined $anon_sub) {
158 1         2 my $lookup = '$$self';
159 1         1 my $count;
160 1         12 for ($count=0;$count<=$#data;$count++) {
161 14         29 $lookup .= '{$$dataref[' . $count . ']}';
162             }
163 1         3 $lookup =<<"EOF";
164             sub {
165             my (\$self,\$dataref) = \@_;
166             return CORE::exists ($lookup);
167             };
168             EOF
169 1         141 $anon_sub = eval ($lookup);
170 1         4 $func_table->{-func_index}->{-exists}->[$#data] = $anon_sub;
171             }
172 8         116 return $self->$anon_sub(\@data);
173             } elsif ($#data == 2) {
174 4         12 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]};
175             } elsif ($#data == 3) {
176 4         13 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]};
177             } elsif ($#data == 4) {
178 4         14 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]};
179             } elsif ($#data == 5) {
180 4         14 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]};
181             } elsif ($#data == 6) {
182 4         16 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]};
183             } elsif ($#data == 7) {
184 4         14 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]};
185             } elsif ($#data == 8) {
186 4         17 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]};
187             } elsif ($#data == 9) {
188 4         17 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]};
189             } elsif ($#data == 10) {
190 4         17 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]};
191             } elsif ($#data == 11) {
192 4         28 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]};
193             } else { # if ($#data == 12) {
194 4         19 return CORE::exists $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]}{$data[12]};
195             }
196             }
197              
198             ####
199              
200             sub get {
201 41     41 1 269 my $self = shift;
202              
203 41         53 my ($data_ref) = @_;
204              
205 41         77 my @data = @$data_ref;
206              
207             # Its _OK_ if the hash element doesn't exist
208 1     1   7 no warnings;
  1         2  
  1         1472  
209              
210 39 100       139 if ($#data == 0) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
211 6         14 return $$self{$data[0]};
212             } elsif ($#data == 1) {
213 6         18 return $$self{$data[0]}{$data[1]};
214             } elsif ($#data > 12) {
215 4         9 my $anon_sub = $func_table->{-func_index}->{-get}->[$#data];
216 4 100       8 unless (defined $anon_sub) {
217 1         1 my $lookup = '$$self';
218 1         2 my $count;
219 1         3 for ($count=0;$count<=$#data;$count++) {
220 14         64 $lookup .= '{$$dataref[' . $count . ']}';
221             }
222 1         4 $lookup =<<"EOF";
223             sub {
224             my (\$self,\$dataref) = \@_;
225             return $lookup;
226             };
227             EOF
228 1         126 $anon_sub = eval ($lookup);
229 1         4 $func_table->{-func_index}->{-get}->[$#data] = $anon_sub;
230             }
231 4         53 return $self->$anon_sub(\@data);
232             } elsif ($#data == 2) {
233 2         40 return $$self{$data[0]}{$data[1]}{$data[2]};
234             } elsif ($#data == 3) {
235 2         6 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]};
236             } elsif ($#data == 4) {
237 2         8 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]};
238             } elsif ($#data == 5) {
239 2         7 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]};
240             } elsif ($#data == 6) {
241 2         7 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]};
242             } elsif ($#data == 7) {
243 2         8 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]};
244             } elsif ($#data == 8) {
245 2         9 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]};
246             } elsif ($#data == 9) {
247 2         9 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]};
248             } elsif ($#data == 10) {
249 2         9 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]};
250             } elsif ($#data == 11) {
251 2         11 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]};
252             } elsif ($#data == 12) {
253 2         11 return $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]}{$data[12]};
254             } else { # if ($#data == -1)
255 1         3 return $self;
256             }
257             }
258              
259             ####
260              
261             sub put {
262 25     25 1 480 my $self = shift;
263              
264 25         33 my ($data_ref,$value) = @_;
265              
266 25         53 my @data = @$data_ref;
267              
268 23 100       135 unless (2 == @_) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
269 2         10 require Carp;
270 2         168 Carp::confess ("Tie::ListKeyedHash::put called without a value to set.\n");
271              
272 0         0 } elsif ($#data == 0) {
273 3         11 $$self{$data[0]} = $value;
274              
275 0         0 } elsif ($#data == 1) {
276 3         34 $$self{$data[0]}{$data[1]} = $value;
277              
278 0         0 } elsif ($#data > 12) {
279 2         6 my $anon_sub = $func_table->{-func_index}->{-put}->[$#data];
280 2 100       5 unless (defined $anon_sub) {
281 1         2 my $lookup = '$$self';
282 1         2 my $count;
283 1         3 for ($count=0;$count<=$#data;$count++) {
284 14         28 $lookup .= '{$$dataref[' . $count . ']}';
285             }
286 1         3 $lookup =<<"EOF";
287             sub {
288             my (\$self,\$dataref,\$valueref) = \@_;
289             $lookup = \$valueref;
290             };
291             EOF
292 1         160 $anon_sub = eval ($lookup);
293 1         5 $func_table->{-func_index}->{-put}->[$#data] = $anon_sub;
294             }
295 2         33 $self->$anon_sub(\@data,$value);
296 0         0 } elsif ($#data == 2) {
297 1         4 $$self{$data[0]}{$data[1]}{$data[2]} = $value;
298 0         0 } elsif ($#data == 3) {
299 1         6 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]} = $value;
300 0         0 } elsif ($#data == 4) {
301 1         10 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]} = $value;
302 0         0 } elsif ($#data == 5) {
303 1         7 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]} = $value;
304 0         0 } elsif ($#data == 6) {
305 1         8 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]} = $value;
306 0         0 } elsif ($#data == 7) {
307 1         20 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]} = $value;
308 0         0 } elsif ($#data == 8) {
309 1         7 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]} = $value;
310 0         0 } elsif ($#data == 9) {
311 1         7 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]} = $value;
312 0         0 } elsif ($#data == 10) {
313 1         24 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]} = $value;
314 0         0 } elsif ($#data == 11) {
315 1         18 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]} = $value;
316 0         0 } elsif ($#data == 12) {
317 1         18 $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]}{$data[12]} = $value;
318             } else { # if ($#data == -1)
319 2         9 require Carp;
320 2         181 Carp::confess ("Tie::ListKeyedHash::put called without a valid key.\n");
321             }
322             }
323              
324             ####
325              
326             sub delete {
327 42     42 1 253 my ($self) = shift;
328              
329 42         50 my ($data_ref) = @_;
330              
331 42         84 my @data = @$data_ref;
332              
333 40 100       155 if ($#data == 0) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
334 6         15 delete $$self{$data[0]};
335             } elsif ($#data == 1) {
336 6         17 delete $$self{$data[0]}{$data[1]};
337             } elsif ($#data > 12) {
338 4         9 my $anon_sub = $func_table->{-func_index}->{-clear}->[$#data];
339 4 100       9 unless (defined $anon_sub) {
340 1         2 my $lookup = '$$self';
341 1         1 my $count;
342 1         4 for ($count=0;$count<=$#data;$count++) {
343 14         26 $lookup .= '{$$dataref[' . $count . ']}';
344             }
345 1         3 $lookup =<<"EOF";
346             sub {
347             my (\$self,\$dataref) = \@_;
348             delete $lookup;
349             };
350             EOF
351 1         123 $anon_sub = eval ($lookup);
352 1         5 $func_table->{-func_index}->{-clear}->[$#data] = $anon_sub;
353             }
354 4         50 $self->$anon_sub(\@data);
355             } elsif ($#data == 2) {
356 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]};
357             } elsif ($#data == 3) {
358 2         9 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]};
359             } elsif ($#data == 4) {
360 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]};
361             } elsif ($#data == 5) {
362 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]};
363             } elsif ($#data == 6) {
364 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]};
365             } elsif ($#data == 7) {
366 2         9 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]};
367             } elsif ($#data == 8) {
368 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]};
369             } elsif ($#data == 9) {
370 2         9 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]};
371             } elsif ($#data == 10) {
372 2         9 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]};
373             } elsif ($#data == 11) {
374 2         12 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]};
375             } elsif ($#data == 12) {
376 2         8 delete $$self{$data[0]}{$data[1]}{$data[2]}{$data[3]}{$data[4]}{$data[5]}{$data[6]}{$data[7]}{$data[8]}{$data[9]}{$data[10]}{$data[11]}{$data[12]};
377             } else { # if ($#data < 0) That is what 'clear' is for ;)
378 2         10 require Carp;
379 2         240 Carp::confess ("Tie::ListKeyedHash::_delete object field called with no fields specified.\n");
380             }
381             }
382              
383             ####
384              
385       0     sub DESTROY {}
386              
387             ####
388              
389             1;