File Coverage

blib/lib/Data/Hive/Store/Hash/Nested.pm
Criterion Covered Total %
statement 79 84 94.0
branch 27 30 90.0
condition 10 14 71.4
subroutine 24 26 92.3
pod 8 8 100.0
total 148 162 91.3


line stmt bran cond sub pod time code
1 1     1   442 use strict;
  1         3  
  1         26  
2 1     1   4 use warnings;
  1         2  
  1         48  
3             package Data::Hive::Store::Hash::Nested 1.014;
4             # ABSTRACT: store a hive in nested hashrefs
5              
6 1     1   368 use parent 'Data::Hive::Store';
  1         258  
  1         4  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod This is a simple store, primarily for testing, that will store hives in nested
11             #pod hashrefs. All hives are represented as hashrefs, and their values are stored
12             #pod in the entry for the empty string.
13             #pod
14             #pod So, we could do this:
15             #pod
16             #pod my $href = {};
17             #pod
18             #pod my $hive = Data::Hive->NEW({
19             #pod store_class => 'Hash',
20             #pod store_args => [ $href ],
21             #pod });
22             #pod
23             #pod $hive->foo->SET(1);
24             #pod $hive->foo->bar->baz->SET(2);
25             #pod
26             #pod We would end up with C<$href> containing:
27             #pod
28             #pod {
29             #pod foo => {
30             #pod '' => 1,
31             #pod bar => {
32             #pod baz => {
33             #pod '' => 2,
34             #pod },
35             #pod },
36             #pod },
37             #pod }
38             #pod
39             #pod Using empty keys results in a bigger, uglier dump, but allows a given hive to
40             #pod contain both a value and subhives. B that this is different
41             #pod behavior compared with earlier releases, in which empty keys were not used and
42             #pod it was not legal to have a value and a hive at a given path. It is possible,
43             #pod although fairly unlikely, that this format will change again. The Hash store
44             #pod should generally be used for testing things that use a hive, as opposed for
45             #pod building hashes that will be used for anything else.
46             #pod
47             #pod =method new
48             #pod
49             #pod my $store = Data::Hive::Store::Hash->new(\%hash);
50             #pod
51             #pod The only argument expected for C is a hashref, which is the hashref in
52             #pod which hive entries are stored.
53             #pod
54             #pod If no hashref is provided, a new, empty hashref will be used.
55             #pod
56             #pod =cut
57              
58             sub new {
59 7     7 1 101 my ($class, $href) = @_;
60 7 100       20 $href = {} unless defined $href;
61              
62 7         33 return bless { store => $href } => $class;
63             }
64              
65             #pod =method hash_store
66             #pod
67             #pod This method returns the hashref in which things are being used. You should not
68             #pod alter its contents!
69             #pod
70             #pod =cut
71              
72             sub hash_store {
73             $_[0]->{store}
74 121     121 1 233 }
75              
76             my $BREAK = "BREAK\n";
77              
78             # Wow, this is quite a little machine! Here's a slightly simplified overview
79             # of what it does: -- rjbs, 2010-08-27
80             #
81             # As long as cond->(\@remaining_path) is true, execute step->($next,
82             # $current_hashref, \@remaining_path)
83             #
84             # If it dies with $BREAK, stop looping and return. Once the cond returns
85             # false, return end->($current_hashref, \@remaining_path)
86             sub _descend {
87 110     110   193 my ($self, $orig_path, $arg) = @_;
88 110         214 my @path = @$orig_path;
89              
90 110   50     188 $arg ||= {};
91 110 50       205 $arg->{step} or die "step is required";
92 110   100 213   481 $arg->{cond} ||= sub { @{ shift() } };
  213         243  
  213         418  
93 110   50 0   186 $arg->{end} ||= sub { $_[0] };
  0         0  
94              
95 110         175 my $node = $self->hash_store;
96              
97 110         215 while ($arg->{cond}->(\@path)) {
98 200         314 my $seg = shift @path;
99              
100             {
101 200         233 local $SIG{__DIE__};
  200         453  
102 200         263 eval { $arg->{step}->($seg, $node, \@path) };
  200         334  
103             }
104              
105 200 100 66     498 return if $@ and $@ eq $BREAK;
106 179 50       259 die $@ if $@;
107 179   100     392 $node = $node->{$seg} ||= {};
108             }
109              
110 89         165 return $arg->{end}->($node, \@path);
111             }
112              
113             sub get {
114 31     31 1 46 my ($self, $path) = @_;
115             return $self->_descend(
116             $path, {
117 23     23   106 end => sub { $_[0]->{''} },
118             step => sub {
119 54     54   97 my ($seg, $node) = @_;
120              
121 54 100       122 die $BREAK unless exists $node->{$seg};
122              
123 46 100       163 $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
124             }
125             }
126 31         175 );
127             }
128              
129             sub set {
130 21     21 1 38 my ($self, $path, $value) = @_;
131             return $self->_descend(
132             $path, {
133             step => sub {
134 31     31   62 my ($seg, $node, $path) = @_;
135 31 50 66     157 if (exists $node->{$seg} and not ref $node->{$seg}) {
136 0         0 _die("can't overwrite existing non-ref value: '$node->{$seg}'");
137             }
138             },
139 52     52   68 cond => sub { @{ shift() } > 1 },
  52         117  
140             end => sub {
141 21     21   34 my ($node, $path) = @_;
142 21         201 $node->{$path->[0]}{''} = $value;
143             },
144             },
145 21         174 );
146             }
147              
148             #pod =method name
149             #pod
150             #pod The name returned by the Hash store is a string, potentially suitable for
151             #pod eval-ing, describing a hash dereference of a variable called C<< $STORE >>.
152             #pod
153             #pod "$STORE->{foo}->{bar}"
154             #pod
155             #pod This is probably not very useful. It might be replaced with something else in
156             #pod the future.
157             #pod
158             #pod =cut
159              
160             sub name {
161 0     0 1 0 my ($self, $path) = @_;
162 0         0 return join '->', '$STORE', map { "{'$_'}" } @$path;
  0         0  
163             }
164              
165             sub exists {
166 30     30 1 51 my ($self, $path) = @_;
167             return $self->_descend(
168             $path, {
169             step => sub {
170 57     57   98 my ($seg, $node) = @_;
171 57 100       144 die $BREAK unless exists $node->{$seg};
172              
173 46 100       143 $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
174             },
175 19     19   142 end => sub { return exists $_[0]->{''}; },
176             },
177 30         163 );
178             }
179              
180             sub delete {
181 8     8 1 13 my ($self, $path) = @_;
182              
183 8         11 my @to_check;
184              
185             return $self->_descend(
186             $path, {
187             step => sub {
188 17     17   30 my ($seg, $node) = @_;
189 17 100       31 die $BREAK unless exists $node->{$seg};
190 16 100       34 $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
191 16         47 push @to_check, [ $node, $seg ];
192             },
193 24     24   34 cond => sub { @{ shift() } > 1 },
  24         50  
194             end => sub {
195 7     7   12 my ($node, $final_path) = @_;
196              
197             $node->{ $final_path->[0] } = { '' => $node->{ $final_path->[0] } }
198 7 100       20 unless ref $node->{ $final_path->[0] };
199              
200 7         11 my $this = $node->{ $final_path->[0] };
201 7         14 my $rv = delete $this->{''};
202              
203             # Cleanup empty trees after deletion! It would be convenient to have
204             # ->_ascend, but I'm not likely to bother with writing it just yet.
205             # -- rjbs, 2010-08-27
206 7         18 for my $to_check (
207             [ $node, $final_path->[0] ],
208             reverse @to_check
209             ) {
210 13         22 my ($node, $seg) = @$to_check;
211 13 100       14 last if keys %{ $node->{$seg} };
  13         31  
212 7         13 delete $node->{ $seg };
213             }
214              
215 7         50 return $rv;
216             },
217             },
218 8         95 );
219             }
220              
221             sub keys {
222 20     20 1 37 my ($self, $path) = @_;
223              
224             return $self->_descend($path, {
225             step => sub {
226 41     41   60 my ($seg, $node) = @_;
227 41 100       69 die $BREAK unless exists $node->{$seg};
228 40 100       113 $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
229             },
230             end => sub {
231 19     19   30 return grep { length } keys %{ $_[0] };
  29         177  
  19         59  
232             },
233 20         121 });
234             }
235              
236             1;
237              
238             __END__