line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
3
|
|
|
3
|
|
1326
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
95
|
|
2
|
3
|
|
|
3
|
|
15
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
110
|
|
3
|
|
|
|
|
|
|
package Data::Hive::Test 1.014; |
4
|
|
|
|
|
|
|
# ABSTRACT: a bundle of tests for Data::Hive stores |
5
|
|
|
|
|
|
|
|
6
|
3
|
|
|
3
|
|
15
|
use Data::Hive; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
71
|
|
7
|
3
|
|
|
3
|
|
790
|
use Data::Hive::Store::Hash; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
82
|
|
8
|
|
|
|
|
|
|
|
9
|
3
|
|
|
3
|
|
1197
|
use Test::More 0.96; # subtest without tests |
|
3
|
|
|
|
|
131803
|
|
|
3
|
|
|
|
|
26
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
#pod =head1 SYNOPSIS |
12
|
|
|
|
|
|
|
#pod |
13
|
|
|
|
|
|
|
#pod use Test::More; |
14
|
|
|
|
|
|
|
#pod |
15
|
|
|
|
|
|
|
#pod use Data::Hive::Test; |
16
|
|
|
|
|
|
|
#pod use Data::Hive::Store::MyNewStore; |
17
|
|
|
|
|
|
|
#pod |
18
|
|
|
|
|
|
|
#pod Data::Hive::Test->test_new_hive({ store_class => 'MyNewStore' }); |
19
|
|
|
|
|
|
|
#pod |
20
|
|
|
|
|
|
|
#pod # rest of your tests for your store |
21
|
|
|
|
|
|
|
#pod |
22
|
|
|
|
|
|
|
#pod done_testing; |
23
|
|
|
|
|
|
|
#pod |
24
|
|
|
|
|
|
|
#pod =head1 DESCRIPTION |
25
|
|
|
|
|
|
|
#pod |
26
|
|
|
|
|
|
|
#pod Data::Hive::Test is a library of tests that should be passable for any |
27
|
|
|
|
|
|
|
#pod conformant L implementation. It provides a method for |
28
|
|
|
|
|
|
|
#pod running a suite of tests -- which may expand or change -- that check the |
29
|
|
|
|
|
|
|
#pod behavior of a hive store by building a hive around it and testing its behavior. |
30
|
|
|
|
|
|
|
#pod |
31
|
|
|
|
|
|
|
#pod =method test_new_hive |
32
|
|
|
|
|
|
|
#pod |
33
|
|
|
|
|
|
|
#pod Data::Hive::Test->test_new_hive( $desc, \%args_to_NEW ); |
34
|
|
|
|
|
|
|
#pod |
35
|
|
|
|
|
|
|
#pod This method expects an (optional) description followed by a hashref of |
36
|
|
|
|
|
|
|
#pod arguments to be passed to Data::Hive's C> method. A new |
37
|
|
|
|
|
|
|
#pod hive will be constructed with those arguments and a single subtest will be run, |
38
|
|
|
|
|
|
|
#pod including subtests that should pass against any conformant Data::Hive::Store |
39
|
|
|
|
|
|
|
#pod implementation. |
40
|
|
|
|
|
|
|
#pod |
41
|
|
|
|
|
|
|
#pod If the tests pass, the method will return the hive. If they fail, the method |
42
|
|
|
|
|
|
|
#pod will return false. |
43
|
|
|
|
|
|
|
#pod |
44
|
|
|
|
|
|
|
#pod =method test_existing_hive |
45
|
|
|
|
|
|
|
#pod |
46
|
|
|
|
|
|
|
#pod Data::Hive::Test->test_existing_hive( $desc, $hive ); |
47
|
|
|
|
|
|
|
#pod |
48
|
|
|
|
|
|
|
#pod This method behaves just like C, but expects a hive rather than |
49
|
|
|
|
|
|
|
#pod arguments to use to build one. |
50
|
|
|
|
|
|
|
#pod |
51
|
|
|
|
|
|
|
#pod =cut |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub test_new_hive { |
54
|
3
|
|
|
3
|
1
|
122
|
my ($self, $desc, $arg) = @_; |
55
|
|
|
|
|
|
|
|
56
|
3
|
50
|
|
|
|
13
|
if (@_ == 2) { |
57
|
0
|
|
|
|
|
0
|
$arg = $desc; |
58
|
0
|
|
|
|
|
0
|
$desc = "hive tests from Data::Hive::Test"; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
3
|
|
|
|
|
19
|
my $hive = Data::Hive->NEW($arg); |
62
|
|
|
|
|
|
|
|
63
|
3
|
|
|
|
|
27
|
test_existing_hive($desc, $hive); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub _set_ok { |
67
|
39
|
|
|
39
|
|
89
|
my ($hive, $value) = @_; |
68
|
39
|
|
|
|
|
77
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
69
|
39
|
|
|
|
|
127
|
is($hive->SET($value), $value, "we return new value from SET"); |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub test_existing_hive { |
73
|
3
|
|
|
3
|
1
|
9
|
my ($self, $desc, $hive) = @_; |
74
|
|
|
|
|
|
|
|
75
|
3
|
50
|
|
|
|
12
|
if (@_ == 2) { |
76
|
3
|
|
|
|
|
6
|
$hive = $desc; |
77
|
3
|
|
|
|
|
7
|
$desc = "hive tests from Data::Hive::Test"; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
3
|
|
|
|
|
10
|
$desc = "Data::Hive::Test: $desc"; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
my $passed = subtest $desc => sub { |
83
|
3
|
|
|
3
|
|
3255
|
isa_ok($hive, 'Data::Hive'); |
84
|
|
|
|
|
|
|
|
85
|
3
|
|
|
|
|
1479
|
is_deeply( |
86
|
|
|
|
|
|
|
[ $hive->KEYS ], |
87
|
|
|
|
|
|
|
[ ], |
88
|
|
|
|
|
|
|
"we're starting with an empty hive", |
89
|
|
|
|
|
|
|
); |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
subtest 'value of one' => sub { |
92
|
3
|
|
|
|
|
2467
|
ok(! $hive->one->EXISTS, "before being set, ->one doesn't EXISTS"); |
93
|
|
|
|
|
|
|
|
94
|
3
|
|
|
|
|
1091
|
_set_ok($hive->one, 1); |
95
|
|
|
|
|
|
|
|
96
|
3
|
|
|
|
|
1188
|
ok($hive->one->EXISTS, "after being set, ->one EXISTS"); |
97
|
|
|
|
|
|
|
|
98
|
3
|
|
|
|
|
1044
|
is($hive->one->GET, 1, "->one->GET is 1"); |
99
|
3
|
|
|
|
|
1150
|
is($hive->one->GET(10), 1, "->one->GET(10) is 1"); |
100
|
|
|
|
|
|
|
|
101
|
3
|
|
|
|
|
1119
|
is($hive->one->GET(sub { 2 }), 1, "->one->GET(sub{2}) is 1"); |
|
0
|
|
|
|
|
0
|
|
102
|
3
|
|
|
|
|
1774
|
}; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
subtest 'value of zero' => sub { |
105
|
3
|
|
|
|
|
2497
|
ok(! $hive->zero->EXISTS, "before being set, ->zero doesn't EXISTS"); |
106
|
|
|
|
|
|
|
|
107
|
3
|
|
|
|
|
1147
|
_set_ok($hive->zero, 0); |
108
|
|
|
|
|
|
|
|
109
|
3
|
|
|
|
|
1173
|
ok($hive->zero->EXISTS, "after being set, ->zero EXISTS"); |
110
|
|
|
|
|
|
|
|
111
|
3
|
|
|
|
|
1116
|
is($hive->zero->GET, 0, "->zero->GET is 0"); |
112
|
3
|
|
|
|
|
1176
|
is($hive->zero->GET(10), 0, "->zero->GET(10) is 0"); |
113
|
3
|
|
|
|
|
4327
|
}; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
subtest 'value of empty string' => sub { |
116
|
3
|
|
|
|
|
2394
|
ok(! $hive->empty->EXISTS, "before being set, ->empty doesn't EXISTS"); |
117
|
|
|
|
|
|
|
|
118
|
3
|
|
|
|
|
1091
|
_set_ok($hive->empty, ''); |
119
|
|
|
|
|
|
|
|
120
|
3
|
|
|
|
|
1125
|
ok($hive->empty->EXISTS, "after being set, ->empty EXISTS"); |
121
|
|
|
|
|
|
|
|
122
|
3
|
|
|
|
|
1066
|
is($hive->empty->GET, '', "->empty->GET is ''"); |
123
|
3
|
|
|
|
|
1124
|
is($hive->empty->GET(10), '', "->empty->GET(10) is ''"); |
124
|
3
|
|
|
|
|
4455
|
}; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
subtest 'undef, existing value' => sub { |
127
|
3
|
|
|
|
|
2383
|
ok(! $hive->undef->EXISTS, "before being set, ->undef doesn't EXISTS"); |
128
|
|
|
|
|
|
|
|
129
|
3
|
|
|
|
|
1094
|
_set_ok($hive->undef, undef); |
130
|
|
|
|
|
|
|
|
131
|
3
|
|
|
|
|
1326
|
ok($hive->undef->EXISTS, "after being set, ->undef EXISTS"); |
132
|
|
|
|
|
|
|
|
133
|
3
|
|
|
|
|
1060
|
is($hive->undef->GET, undef, "->undef->GET is undef"); |
134
|
3
|
|
|
|
|
1363
|
is($hive->undef->GET(10), 10, "->undef->GET(10) is 10"); |
135
|
3
|
|
|
|
|
1134
|
is($hive->undef->GET(sub{2}), 2, "->undef->GET(sub{2}) is 2"); |
|
3
|
|
|
|
|
13
|
|
136
|
3
|
|
|
|
|
3715
|
}; |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
subtest 'non-existing value' => sub { |
139
|
3
|
|
|
|
|
2332
|
ok(! $hive->missing->EXISTS, "before being set, ->missing doesn't EXISTS"); |
140
|
|
|
|
|
|
|
|
141
|
3
|
|
|
|
|
1060
|
is($hive->missing->GET, undef, "->missing is undef"); |
142
|
|
|
|
|
|
|
|
143
|
3
|
|
|
|
|
1339
|
ok(! $hive->missing->EXISTS, "mere GET-ing won't cause ->missing to EXIST"); |
144
|
|
|
|
|
|
|
|
145
|
3
|
|
|
|
|
1106
|
is($hive->missing->GET(10), 10, "->missing->GET(10) is 10"); |
146
|
3
|
|
|
|
|
1183
|
is($hive->missing->GET(sub{2}), 2, "->missing->GET(sub{2}) is 2"); |
|
3
|
|
|
|
|
19
|
|
147
|
3
|
|
|
|
|
3807
|
}; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
subtest 'nested value' => sub { |
150
|
3
|
|
|
|
|
2363
|
ok( |
151
|
|
|
|
|
|
|
! $hive->two->EXISTS, |
152
|
|
|
|
|
|
|
"before setting ->two->deep, ->two doesn't EXISTS" |
153
|
|
|
|
|
|
|
); |
154
|
|
|
|
|
|
|
|
155
|
3
|
|
|
|
|
1057
|
ok( |
156
|
|
|
|
|
|
|
! $hive->two->deep->EXISTS, |
157
|
|
|
|
|
|
|
"before setting ->two->deep, ->two->deep doesn't EXISTS" |
158
|
|
|
|
|
|
|
); |
159
|
|
|
|
|
|
|
|
160
|
3
|
|
|
|
|
1073
|
is( |
161
|
|
|
|
|
|
|
$hive->two->deep->GET, |
162
|
|
|
|
|
|
|
undef, |
163
|
|
|
|
|
|
|
"before being set, ->two->deep is undef" |
164
|
|
|
|
|
|
|
); |
165
|
|
|
|
|
|
|
|
166
|
3
|
|
|
|
|
1346
|
_set_ok($hive->two->deep, '2D'); |
167
|
|
|
|
|
|
|
|
168
|
3
|
|
|
|
|
1120
|
ok( |
169
|
|
|
|
|
|
|
! $hive->two->EXISTS, |
170
|
|
|
|
|
|
|
"after setting ->two->deep, ->two still doesn't EXISTS" |
171
|
|
|
|
|
|
|
); |
172
|
|
|
|
|
|
|
|
173
|
3
|
|
|
|
|
1377
|
ok( |
174
|
|
|
|
|
|
|
$hive->two->deep->EXISTS, |
175
|
|
|
|
|
|
|
"after setting ->two->deep, ->two->deep EXISTS" |
176
|
|
|
|
|
|
|
); |
177
|
|
|
|
|
|
|
|
178
|
3
|
|
|
|
|
1093
|
is( |
179
|
|
|
|
|
|
|
$hive->two->deep->GET, |
180
|
|
|
|
|
|
|
'2D', |
181
|
|
|
|
|
|
|
"after being set, ->two->deep->GET returns '2D'", |
182
|
|
|
|
|
|
|
); |
183
|
|
|
|
|
|
|
|
184
|
3
|
|
|
|
|
1162
|
is( |
185
|
|
|
|
|
|
|
$hive->two->deep->GET(10), |
186
|
|
|
|
|
|
|
'2D', |
187
|
|
|
|
|
|
|
"after being set, ->two->deep->GET(10) returns '2D'", |
188
|
|
|
|
|
|
|
); |
189
|
3
|
|
|
|
|
3671
|
}; |
190
|
|
|
|
|
|
|
|
191
|
3
|
|
|
|
|
3858
|
is_deeply( |
192
|
|
|
|
|
|
|
[ sort $hive->KEYS ], |
193
|
|
|
|
|
|
|
[ qw(empty one two undef zero) ], |
194
|
|
|
|
|
|
|
"in the end, we have the right top-level keys", |
195
|
|
|
|
|
|
|
); |
196
|
|
|
|
|
|
|
|
197
|
3
|
|
|
|
|
1959
|
is( |
198
|
|
|
|
|
|
|
$hive->two->deep->fake->whatever->ROOT->two->deep->GET, |
199
|
|
|
|
|
|
|
'2D', |
200
|
|
|
|
|
|
|
"we can get back to the root easily with ROOT", |
201
|
|
|
|
|
|
|
); |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
subtest 'COPY_ONTO' => sub { |
204
|
3
|
|
|
|
|
2493
|
_set_ok( $hive->copy->x->y->z, 1); |
205
|
3
|
|
|
|
|
1134
|
_set_ok( $hive->copy->a->b, 2); |
206
|
3
|
|
|
|
|
1136
|
_set_ok( $hive->copy->a->b->c->d, 3); |
207
|
|
|
|
|
|
|
|
208
|
3
|
|
|
|
|
1251
|
my $target = Data::Hive->NEW({ store => Data::Hive::Store::Hash->new }); |
209
|
|
|
|
|
|
|
|
210
|
3
|
|
|
|
|
18
|
$hive->copy->COPY_ONTO($target->clone); |
211
|
|
|
|
|
|
|
|
212
|
3
|
|
|
|
|
11
|
is_deeply( |
213
|
|
|
|
|
|
|
$target->STORE->hash_store, |
214
|
|
|
|
|
|
|
{ |
215
|
|
|
|
|
|
|
'clone.x.y.z' => '1', |
216
|
|
|
|
|
|
|
'clone.a.b' => '2', |
217
|
|
|
|
|
|
|
'clone.a.b.c.d' => '3', |
218
|
|
|
|
|
|
|
}, |
219
|
|
|
|
|
|
|
"we can copy structures", |
220
|
|
|
|
|
|
|
); |
221
|
3
|
|
|
|
|
1101
|
}; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
subtest 'DELETE' => sub { |
224
|
3
|
|
|
|
|
2476
|
_set_ok($hive->to_delete->top, 10); |
225
|
3
|
|
|
|
|
1178
|
_set_ok($hive->to_delete->top->middle, 20); |
226
|
3
|
|
|
|
|
1172
|
_set_ok($hive->to_delete->top->middle->bottom, 20); |
227
|
|
|
|
|
|
|
|
228
|
3
|
|
|
|
|
1142
|
$hive->to_delete->top->middle->DELETE; |
229
|
|
|
|
|
|
|
|
230
|
3
|
|
|
|
|
27
|
ok( |
231
|
|
|
|
|
|
|
$hive->to_delete->top->EXISTS, |
232
|
|
|
|
|
|
|
"delete middle, top is still there", |
233
|
|
|
|
|
|
|
); |
234
|
|
|
|
|
|
|
|
235
|
3
|
|
|
|
|
1075
|
ok( |
236
|
|
|
|
|
|
|
! $hive->to_delete->top->middle->EXISTS, |
237
|
|
|
|
|
|
|
"delete middle, so it is gone", |
238
|
|
|
|
|
|
|
); |
239
|
|
|
|
|
|
|
|
240
|
3
|
|
|
|
|
1138
|
ok( |
241
|
|
|
|
|
|
|
$hive->to_delete->top->middle->bottom->EXISTS, |
242
|
|
|
|
|
|
|
"delete middle, bottom is still there", |
243
|
|
|
|
|
|
|
); |
244
|
3
|
|
|
|
|
3956
|
}; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
subtest 'DELETE_ALL' => sub { |
247
|
3
|
|
|
|
|
2311
|
_set_ok($hive->doomed->alpha->branch->value, 1); |
248
|
3
|
|
|
|
|
1149
|
_set_ok($hive->doomed->bravo->branch->value, 1); |
249
|
|
|
|
|
|
|
|
250
|
3
|
|
|
|
|
1176
|
is_deeply( |
251
|
|
|
|
|
|
|
[ sort $hive->doomed->KEYS ], |
252
|
|
|
|
|
|
|
[ qw(alpha bravo) ], |
253
|
|
|
|
|
|
|
"created hive with two subhives", |
254
|
|
|
|
|
|
|
); |
255
|
|
|
|
|
|
|
|
256
|
3
|
|
|
|
|
2008
|
$hive->doomed->alpha->DELETE_ALL; |
257
|
|
|
|
|
|
|
|
258
|
3
|
|
|
|
|
19
|
is_deeply( |
259
|
|
|
|
|
|
|
[ sort $hive->doomed->KEYS ], |
260
|
|
|
|
|
|
|
[ qw(bravo) ], |
261
|
|
|
|
|
|
|
"doing a DELETE_ALL gets rid of all deeper values", |
262
|
|
|
|
|
|
|
); |
263
|
|
|
|
|
|
|
|
264
|
3
|
|
|
|
|
1732
|
is( |
265
|
|
|
|
|
|
|
$hive->doomed->alpha->branch->value->GET, |
266
|
|
|
|
|
|
|
undef, |
267
|
|
|
|
|
|
|
"the deeper value is now undef", |
268
|
|
|
|
|
|
|
); |
269
|
|
|
|
|
|
|
|
270
|
3
|
|
|
|
|
1377
|
ok( |
271
|
|
|
|
|
|
|
! $hive->doomed->alpha->branch->value->EXISTS, |
272
|
|
|
|
|
|
|
"the deeper value does not exist", |
273
|
|
|
|
|
|
|
); |
274
|
|
|
|
|
|
|
|
275
|
3
|
|
|
|
|
1157
|
is( |
276
|
|
|
|
|
|
|
$hive->doomed->bravo->branch->value->GET, |
277
|
|
|
|
|
|
|
1, |
278
|
|
|
|
|
|
|
"the deep value on another branch is not gone", |
279
|
|
|
|
|
|
|
); |
280
|
3
|
|
|
|
|
3964
|
}; |
281
|
3
|
|
|
|
|
30
|
}; |
282
|
|
|
|
|
|
|
|
283
|
3
|
50
|
|
|
|
8266
|
return $passed ? $hive : (); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
1; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
__END__ |