File Coverage

blib/lib/Tie/CPHash.pm
Criterion Covered Total %
statement 37 39 94.8
branch 13 14 92.8
condition n/a
subroutine 14 14 100.0
pod 2 2 100.0
total 66 69 95.6


line stmt bran cond sub pod time code
1             #---------------------------------------------------------------------
2             package Tie::CPHash;
3             #
4             # Copyright 1997-2012 Christopher J. Madsen
5             #
6             # Author: Christopher J. Madsen
7             # Created: 08 Nov 1997
8             #
9             # This program is free software; you can redistribute it and/or modify
10             # it under the same terms as Perl itself.
11             #
12             # This program is distributed in the hope that it will be useful,
13             # but WITHOUT ANY WARRANTY; without even the implied warranty of
14             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
15             # GNU General Public License or the Artistic License for more details.
16             #
17             # ABSTRACT: Case preserving but case insensitive hash table
18             #---------------------------------------------------------------------
19              
20 2     2   36553 use 5.006;
  2         6  
  2         66  
21 2     2   8 use strict;
  2         2  
  2         97  
22 2     2   14 use warnings;
  2         1  
  2         882  
23              
24             #=====================================================================
25             # Package Global Variables:
26              
27             our $VERSION = '2.000';
28             # This file is part of Tie-CPHash 2.000 (January 17, 2015)
29              
30             #=====================================================================
31             # Tied Methods:
32             #---------------------------------------------------------------------
33             # TIEHASH classname
34             # The method invoked by the command `tie %hash, classname'.
35             # Associates a new hash instance with the specified class.
36              
37             sub TIEHASH
38             {
39 3     3   1104 my $self = bless {}, shift;
40              
41 3 100       16 $self->add(\@_) if @_;
42              
43 3         13 return $self;
44             } # end TIEHASH
45              
46             #---------------------------------------------------------------------
47             # STORE this, key, value
48             # Store datum *value* into *key* for the tied hash *this*.
49              
50             sub STORE
51             {
52 3     3   343 $_[0]->{lc $_[1]} = [ $_[1], $_[2] ];
53             } # end STORE
54              
55             #---------------------------------------------------------------------
56             # FETCH this, key
57             # Retrieve the datum in *key* for the tied hash *this*.
58              
59             sub FETCH
60             {
61 7     7   1242 my $v = $_[0]->{lc $_[1]};
62 7 100       32 ($v ? $v->[1] : undef);
63             } # end FETCH
64              
65             #---------------------------------------------------------------------
66             # FIRSTKEY this
67             # Return the (key, value) pair for the first key in the hash.
68              
69             sub FIRSTKEY
70             {
71 1     1   487 my $a = scalar keys %{$_[0]};
  1         3  
72 1         4 &NEXTKEY;
73             } # end FIRSTKEY
74              
75             #---------------------------------------------------------------------
76             # NEXTKEY this, lastkey
77             # Return the next (key, value) pair for the hash.
78              
79             sub NEXTKEY
80             {
81 2     2   2 my $v = (each %{$_[0]})[1];
  2         5  
82 2 100       12 ($v ? $v->[0] : undef );
83             } # end NEXTKEY
84              
85             #---------------------------------------------------------------------
86             # SCALAR this
87             # Return bucket usage information for the hash (0 if empty).
88              
89             sub SCALAR
90             {
91 4     4   12 scalar %{$_[0]};
  4         846  
92             } # end SCALAR
93              
94             #---------------------------------------------------------------------
95             # EXISTS this, key
96             # Verify that *key* exists with the tied hash *this*.
97              
98             sub EXISTS
99             {
100 2     2   322 exists $_[0]->{lc $_[1]};
101             } # end EXISTS
102              
103             #---------------------------------------------------------------------
104             # DELETE this, key
105             # Delete the key *key* from the tied hash *this*.
106             # Returns the old value, or undef if it didn't exist.
107              
108             sub DELETE
109             {
110 2     2   381 my $v = delete $_[0]->{lc $_[1]};
111 2 100       12 ($v ? $v->[1] : undef);
112             } # end DELETE
113              
114             #---------------------------------------------------------------------
115             # CLEAR this
116             # Clear all values from the tied hash *this*.
117              
118             sub CLEAR
119             {
120 1     1   2 %{$_[0]} = ();
  1         29  
121             } # end CLEAR
122              
123             #=====================================================================
124             # Other Methods:
125             #---------------------------------------------------------------------
126              
127              
128             sub add
129             {
130 3     3 1 4 my $self = shift;
131 3 100       9 my $list = (@_ == 1) ? shift : \@_;
132 3         5 my $limit = $#$list;
133              
134 3 50       9 unless ($limit % 2) {
135 0         0 require Carp;
136 0         0 Carp::croak("Odd number of elements in CPHash add");
137             }
138              
139 3         9 for (my $i = 0; $i < $limit; $i+=2 ) {
140 4         23 $self->{lc $list->[$i]} = [ @$list[$i, $i+1] ];
141             }
142              
143 3         5 return $self;
144             } # end add
145              
146             # Aliases for Tie::IxHash users:
147             *Push = \&add;
148             *Unshift = \&add;
149             #---------------------------------------------------------------------
150              
151              
152             sub key
153             {
154 6     6 1 1477 my $v = $_[0]->{lc $_[1]};
155 6 100       32 ($v ? $v->[0] : undef);
156             }
157              
158             #=====================================================================
159             # Package Return Value:
160              
161             1;
162              
163             __END__