File Coverage

lib/Tie/ListKeyedHash.pm
Criterion Covered Total %
statement 179 180 99.4
branch 142 142 100.0
condition n/a
subroutine 16 17 94.1
pod 6 6 100.0
total 343 345 99.4


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