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__ |