File Coverage

blib/lib/Tie/Hash/Sorted.pm
Criterion Covered Total %
statement 113 114 99.1
branch 14 16 87.5
condition 9 9 100.0
subroutine 31 32 96.8
pod 4 4 100.0
total 171 175 97.7


line stmt bran cond sub pod time code
1             package Tie::Hash::Sorted;
2             require 5.005_03;
3 1     1   7828 use strict;
  1         3  
  1         34  
4 1     1   6 use Carp;
  1         1  
  1         64  
5 1     1   5 use vars '$VERSION';
  1         6  
  1         47  
6 1     1   919 use UNIVERSAL 'isa';
  1         13  
  1         5  
7              
8 1     1   408 use constant FIRST_KEY => -1;
  1         2  
  1         72  
9 1     1   6 use constant STORED_HASH => 0;
  1         1  
  1         40  
10 1     1   5 use constant ITERATOR => 1;
  1         2  
  1         41  
11 1     1   4 use constant SORTED_KEYS => 2;
  1         2  
  1         45  
12 1     1   5 use constant SORT_ROUTINE => 3;
  1         2  
  1         37  
13 1     1   4 use constant STORE_ROUTINE => 4;
  1         2  
  1         40  
14 1     1   4 use constant CHANGED => 5;
  1         2  
  1         35  
15 1     1   5 use constant OPTIMIZATION => 6;
  1         1  
  1         57  
16              
17             $VERSION = '0.10';
18              
19 1     1   1700 BEGIN { *NEXTKEY = \&_FetchKey };
20              
21             sub TIEHASH {
22 18     18   2259 my $class = shift;
23 18 100       248 croak "Incorrect number of parameters" if @_ % 2;
24 17         44 my $self = bless [], $class;
25 17         51 $self->_Build(@_);
26 15         41 return $self;
27             }
28              
29             sub FETCH {
30 28     28   86 my($self, $key) = @_;
31 28         89 return $self->[STORED_HASH]{$key};
32             }
33              
34             sub STORE {
35 26     26   78 my ($self, $key, $value) = @_;
36 26         70 $self->[STORE_ROUTINE]{$self->[OPTIMIZATION]}->($self, $key, $value);
37 26         73 return;
38             }
39              
40             sub EXISTS {
41 3     3   26 my($self, $key) = @_;
42 3         10 return exists $self->[STORED_HASH]{$key};
43             }
44              
45             sub DELETE {
46 7     7   130 my($self, $key) = @_;
47 7 100       21 if (exists $self->[STORED_HASH]{$key}) {
48 6         7 $self->[CHANGED] = 1;
49 6         28 return delete $self->[STORED_HASH]{$key};
50             }
51 1         3 return undef;
52             }
53              
54             sub FIRSTKEY {
55 27     27   181 my $self = shift;
56 27 100 100     140 $self->_ReOrder if $self->[OPTIMIZATION] eq 'none' || $self->[CHANGED];
57 27         80 $self->[ITERATOR] = FIRST_KEY;
58 27         82 return $self->_FetchKey;
59             }
60              
61             sub CLEAR {
62 6     6   81 my $self = shift;
63 6         7 %{$self->[STORED_HASH]} = ();
  6         13  
64 6         9 @{$self->[SORTED_KEYS]} = ();
  6         13  
65 6         8 $self->[CHANGED] = 1;
66 6         25 return;
67             }
68              
69             sub DESTROY {
70 0     0   0 return;
71             }
72              
73             sub Sort_Routine {
74 18     18 1 31 my ($self, $sort) = @_;
75 18 100       198 croak "Not a code ref" if ! isa($sort, 'CODE');
76 17         37 $self->[SORT_ROUTINE] = $sort;
77 17         31 $self->[CHANGED] = 1;
78 17         27 return;
79             }
80              
81             sub Optimization {
82 17     17 1 35 my ($self, $type) = @_;
83 17   100     52 $type ||= 'default';
84 17 100       195 croak "Invalid optimization type"
85             if $type !~ /^(?:default|none|keys|values)$/;
86 16         36 $self->[OPTIMIZATION] = $type;
87 16         29 $self->[CHANGED] = 1;
88             }
89              
90             sub Resort {
91 4     4 1 20 my $self = shift;
92 4         5 $self->[CHANGED] = 1;
93 4         34 return;
94             }
95              
96             sub Count {
97 2     2 1 9 my $self = shift;
98 2         3 return scalar keys %{$self->[STORED_HASH]};
  2         5  
99             }
100              
101             sub _Build {
102 17     17   70 my ($self, %opt) = @_;
103             my $sort = $opt{Sort_Routine} || sub {
104 6     6   9 my $hash = shift;
105 6         60 [ sort {$a cmp $b || $a <=> $b} keys %$hash ];
  28         72  
106 17   100     90 };
107              
108 17         40 $self->Sort_Routine($sort);
109 16         47 $self->Optimization($opt{Optimization});
110              
111 15   100     52 my $hash = $opt{Hash} || {};
112 15 50       40 croak "$hash is not a hash ref" if ! isa($hash, 'HASH');
113 15         74 @{$self->[STORED_HASH]}{keys %$hash} = values %$hash;
  15         47  
114              
115 15         75 $self->[STORE_ROUTINE] = {
116             'default' => \&_Store_NoOpt,
117             'none' => \&_Store_NoOpt,
118             'keys' => \&_Store_KeyOpt,
119             'values' => \&_Store_ValueOpt
120             };
121 15         49 return;
122             }
123              
124             sub _ReOrder {
125 19     19   23 my $self = shift;
126 19         47 $self->[SORTED_KEYS] = $self->[SORT_ROUTINE]->($self->[STORED_HASH]);
127 19         245 $self->[CHANGED] = 0;
128 19         26 return;
129             }
130              
131             sub _FetchKey {
132 139     139   211 my ($self, $lastkey) = @_;
133 139         148 $self->[ITERATOR]++;
134 139         614 return $self->[SORTED_KEYS][$self->[ITERATOR]];
135             }
136              
137             sub _Store_KeyOpt {
138 5     5   7 my($self, $key, $value) = @_;
139 5 100       15 $self->[CHANGED] = 1 if ! exists $self->[STORED_HASH]{$key};
140 5         9 $self->[STORED_HASH]{$key} = $value;
141 5         7 return;
142             }
143              
144             sub _Store_ValueOpt {
145 1     1   3 my($self, $key, $value) = @_;
146 1 50       16 $self->[CHANGED] = 1 if $value ne $self->[STORED_HASH]{$key};
147 1         4 $self->[STORED_HASH]{$key} = $value;
148 1         3 return;
149             }
150              
151             sub _Store_NoOpt {
152 20     20   32 my($self, $key, $value) = @_;
153 20         35 $self->[STORED_HASH]{$key} = $value;
154 20         25 $self->[CHANGED] = 1;
155 20         30 return;
156             }
157              
158             1;
159             __END__