Commit | Line | Data |
6fe26b29 |
1 | package DBM::Deep::Array; |
2 | |
2120a181 |
3 | use 5.006_000; |
460b1067 |
4 | |
6fe26b29 |
5 | use strict; |
d426259c |
6 | use warnings FATAL => 'all'; |
8385c429 |
7 | no warnings 'recursion'; |
29460253 |
8 | |
8fec41b9 |
9 | # This is to allow DBM::Deep::Array to handle negative indices on |
10 | # its own. Otherwise, Perl would intercept the call to negative |
11 | # indices for us. This was causing bugs for negative index handling. |
460b1067 |
12 | our $NEGATIVE_INDICES = 1; |
7910cf68 |
13 | |
6fe26b29 |
14 | use base 'DBM::Deep'; |
15 | |
e1b265cc |
16 | use Scalar::Util (); |
17 | |
596e9574 |
18 | sub _get_self { |
8db25060 |
19 | eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] |
596e9574 |
20 | } |
21 | |
e00d0eb3 |
22 | sub _repr { [] } |
2120a181 |
23 | |
6fe26b29 |
24 | sub TIEARRAY { |
6fe26b29 |
25 | my $class = shift; |
0ca7ea98 |
26 | my $args = $class->_get_args( @_ ); |
504185fb |
27 | |
28 | $args->{type} = $class->TYPE_ARRAY; |
29 | |
9c87a079 |
30 | return $class->_init($args); |
6fe26b29 |
31 | } |
32 | |
7f441181 |
33 | sub FETCH { |
eea0d863 |
34 | my $self = shift->_get_self; |
35 | my ($key) = @_; |
7f441181 |
36 | |
5c0756fc |
37 | $self->lock_shared; |
9a187d8c |
38 | |
2120a181 |
39 | if ( !defined $key ) { |
888453b9 |
40 | $self->unlock; |
2120a181 |
41 | DBM::Deep->_throw_error( "Cannot use an undefined array index." ); |
42 | } |
43 | elsif ( $key =~ /^-?\d+$/ ) { |
7f441181 |
44 | if ( $key < 0 ) { |
45 | $key += $self->FETCHSIZE; |
9281d66b |
46 | unless ( $key >= 0 ) { |
47 | $self->unlock; |
48 | return; |
49 | } |
7f441181 |
50 | } |
c3aafc14 |
51 | } |
2120a181 |
52 | elsif ( $key ne 'length' ) { |
53 | $self->unlock; |
54 | DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); |
7f441181 |
55 | } |
56 | |
2120a181 |
57 | my $rv = $self->SUPER::FETCH( $key ); |
9281d66b |
58 | |
59 | $self->unlock; |
60 | |
61 | return $rv; |
7f441181 |
62 | } |
63 | |
cb79ec85 |
64 | sub STORE { |
65 | my $self = shift->_get_self; |
66 | my ($key, $value) = @_; |
67 | |
5c0756fc |
68 | $self->lock_exclusive; |
9281d66b |
69 | |
9ab67b8c |
70 | my $size; |
c3aafc14 |
71 | my $idx_is_numeric; |
2120a181 |
72 | if ( !defined $key ) { |
888453b9 |
73 | $self->unlock; |
2120a181 |
74 | DBM::Deep->_throw_error( "Cannot use an undefined array index." ); |
75 | } |
76 | elsif ( $key =~ /^-?\d+$/ ) { |
c3aafc14 |
77 | $idx_is_numeric = 1; |
cb79ec85 |
78 | if ( $key < 0 ) { |
9ab67b8c |
79 | $size = $self->FETCHSIZE; |
c3aafc14 |
80 | if ( $key + $size < 0 ) { |
81 | die( "Modification of non-creatable array value attempted, subscript $key" ); |
baa27ab6 |
82 | } |
c3aafc14 |
83 | $key += $size |
cb79ec85 |
84 | } |
cb79ec85 |
85 | } |
2120a181 |
86 | elsif ( $key ne 'length' ) { |
87 | $self->unlock; |
88 | DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); |
89 | } |
cb79ec85 |
90 | |
2120a181 |
91 | my $rv = $self->SUPER::STORE( $key, $value ); |
cb79ec85 |
92 | |
c3aafc14 |
93 | if ( $idx_is_numeric ) { |
9ab67b8c |
94 | $size = $self->FETCHSIZE unless defined $size; |
c3aafc14 |
95 | if ( $key >= $size ) { |
96 | $self->STORESIZE( $key + 1 ); |
9ab67b8c |
97 | } |
cb79ec85 |
98 | } |
99 | |
9281d66b |
100 | $self->unlock; |
101 | |
cb79ec85 |
102 | return $rv; |
103 | } |
104 | |
baa27ab6 |
105 | sub EXISTS { |
eea0d863 |
106 | my $self = shift->_get_self; |
107 | my ($key) = @_; |
baa27ab6 |
108 | |
5c0756fc |
109 | $self->lock_shared; |
9281d66b |
110 | |
2120a181 |
111 | if ( !defined $key ) { |
888453b9 |
112 | $self->unlock; |
2120a181 |
113 | DBM::Deep->_throw_error( "Cannot use an undefined array index." ); |
114 | } |
115 | elsif ( $key =~ /^-?\d+$/ ) { |
baa27ab6 |
116 | if ( $key < 0 ) { |
117 | $key += $self->FETCHSIZE; |
9281d66b |
118 | unless ( $key >= 0 ) { |
119 | $self->unlock; |
120 | return; |
121 | } |
122 | } |
9281d66b |
123 | } |
2120a181 |
124 | elsif ( $key ne 'length' ) { |
125 | $self->unlock; |
126 | DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); |
127 | } |
9281d66b |
128 | |
129 | my $rv = $self->SUPER::EXISTS( $key ); |
130 | |
131 | $self->unlock; |
132 | |
133 | return $rv; |
134 | } |
135 | |
136 | sub DELETE { |
eea0d863 |
137 | my $self = shift->_get_self; |
138 | my ($key) = @_; |
6e6789b0 |
139 | warn "ARRAY::DELETE($self,$key)\n" if DBM::Deep::DEBUG; |
9281d66b |
140 | |
5c0756fc |
141 | $self->lock_exclusive; |
9281d66b |
142 | |
143 | my $size = $self->FETCHSIZE; |
2120a181 |
144 | if ( !defined $key ) { |
888453b9 |
145 | $self->unlock; |
2120a181 |
146 | DBM::Deep->_throw_error( "Cannot use an undefined array index." ); |
147 | } |
148 | elsif ( $key =~ /^-?\d+$/ ) { |
9281d66b |
149 | if ( $key < 0 ) { |
150 | $key += $size; |
151 | unless ( $key >= 0 ) { |
152 | $self->unlock; |
153 | return; |
154 | } |
baa27ab6 |
155 | } |
baa27ab6 |
156 | } |
2120a181 |
157 | elsif ( $key ne 'length' ) { |
158 | $self->unlock; |
159 | DBM::Deep->_throw_error( "Cannot use '$key' as an array index." ); |
160 | } |
baa27ab6 |
161 | |
c3aafc14 |
162 | my $rv = $self->SUPER::DELETE( $key ); |
9281d66b |
163 | |
c3aafc14 |
164 | if ($rv && $key == $size - 1) { |
2120a181 |
165 | $self->STORESIZE( $key ); |
504185fb |
166 | } |
9281d66b |
167 | |
168 | $self->unlock; |
169 | |
170 | return $rv; |
baa27ab6 |
171 | } |
172 | |
d426259c |
173 | # Now that we have a real Reference sector, we should store arrayzize there. |
174 | # However, arraysize needs to be transactionally-aware, so a simple location to |
175 | # store it isn't going to work. |
6fe26b29 |
176 | sub FETCHSIZE { |
9281d66b |
177 | my $self = shift->_get_self; |
178 | |
5c0756fc |
179 | $self->lock_shared; |
9281d66b |
180 | |
f1879fdc |
181 | my $SAVE_FILTER = $self->_engine->storage->{filter_fetch_value}; |
182 | $self->_engine->storage->{filter_fetch_value} = undef; |
504185fb |
183 | |
2120a181 |
184 | my $size = $self->FETCH('length') || 0; |
504185fb |
185 | |
f1879fdc |
186 | $self->_engine->storage->{filter_fetch_value} = $SAVE_FILTER; |
504185fb |
187 | |
9281d66b |
188 | $self->unlock; |
189 | |
2120a181 |
190 | return $size; |
6fe26b29 |
191 | } |
192 | |
193 | sub STORESIZE { |
eea0d863 |
194 | my $self = shift->_get_self; |
504185fb |
195 | my ($new_length) = @_; |
196 | |
5c0756fc |
197 | $self->lock_exclusive; |
9281d66b |
198 | |
f1879fdc |
199 | my $SAVE_FILTER = $self->_engine->storage->{filter_store_value}; |
200 | $self->_engine->storage->{filter_store_value} = undef; |
504185fb |
201 | |
2120a181 |
202 | my $result = $self->STORE('length', $new_length, 'length'); |
504185fb |
203 | |
f1879fdc |
204 | $self->_engine->storage->{filter_store_value} = $SAVE_FILTER; |
504185fb |
205 | |
9281d66b |
206 | $self->unlock; |
207 | |
504185fb |
208 | return $result; |
6fe26b29 |
209 | } |
210 | |
211 | sub POP { |
eea0d863 |
212 | my $self = shift->_get_self; |
9281d66b |
213 | |
5c0756fc |
214 | $self->lock_exclusive; |
9281d66b |
215 | |
504185fb |
216 | my $length = $self->FETCHSIZE(); |
217 | |
218 | if ($length) { |
219 | my $content = $self->FETCH( $length - 1 ); |
220 | $self->DELETE( $length - 1 ); |
9281d66b |
221 | |
222 | $self->unlock; |
223 | |
504185fb |
224 | return $content; |
225 | } |
226 | else { |
9281d66b |
227 | $self->unlock; |
504185fb |
228 | return; |
229 | } |
6fe26b29 |
230 | } |
231 | |
232 | sub PUSH { |
2ac02042 |
233 | my $self = shift->_get_self; |
504185fb |
234 | |
5c0756fc |
235 | $self->lock_exclusive; |
9281d66b |
236 | |
504185fb |
237 | my $length = $self->FETCHSIZE(); |
9281d66b |
238 | |
504185fb |
239 | while (my $content = shift @_) { |
240 | $self->STORE( $length, $content ); |
241 | $length++; |
242 | } |
8f6d6ed0 |
243 | |
9281d66b |
244 | $self->unlock; |
245 | |
8f6d6ed0 |
246 | return $length; |
6fe26b29 |
247 | } |
248 | |
807f63a7 |
249 | # XXX This really needs to be something more direct within the file, not a |
250 | # fetch and re-store. -RobK, 2007-09-20 |
251 | sub _move_value { |
252 | my $self = shift; |
253 | my ($old_key, $new_key) = @_; |
254 | |
1cff45d7 |
255 | return $self->_engine->make_reference( $self, $old_key, $new_key ); |
807f63a7 |
256 | } |
257 | |
6fe26b29 |
258 | sub SHIFT { |
eea0d863 |
259 | my $self = shift->_get_self; |
9c87a079 |
260 | warn "SHIFT($self)\n" if DBM::Deep::DEBUG; |
9281d66b |
261 | |
5c0756fc |
262 | $self->lock_exclusive; |
9281d66b |
263 | |
504185fb |
264 | my $length = $self->FETCHSIZE(); |
265 | |
1cff45d7 |
266 | if ( !$length ) { |
9281d66b |
267 | $self->unlock; |
504185fb |
268 | return; |
269 | } |
1cff45d7 |
270 | |
edd45134 |
271 | my $content = $self->DELETE( 0 ); |
1cff45d7 |
272 | |
edd45134 |
273 | # Unless the deletion above has cleared the array ... |
274 | if ( $length > 1 ) { |
275 | for (my $i = 0; $i < $length - 1; $i++) { |
276 | $self->_move_value( $i+1, $i ); |
277 | } |
6e6789b0 |
278 | |
edd45134 |
279 | $self->DELETE( $length - 1 ); |
280 | } |
1cff45d7 |
281 | |
282 | $self->unlock; |
283 | |
284 | return $content; |
6fe26b29 |
285 | } |
286 | |
287 | sub UNSHIFT { |
2ac02042 |
288 | my $self = shift->_get_self; |
504185fb |
289 | my @new_elements = @_; |
9281d66b |
290 | |
5c0756fc |
291 | $self->lock_exclusive; |
9281d66b |
292 | |
504185fb |
293 | my $length = $self->FETCHSIZE(); |
294 | my $new_size = scalar @new_elements; |
295 | |
296 | if ($length) { |
297 | for (my $i = $length - 1; $i >= 0; $i--) { |
807f63a7 |
298 | $self->_move_value( $i, $i+$new_size ); |
504185fb |
299 | } |
1cff45d7 |
300 | |
301 | $self->STORESIZE( $length + $new_size ); |
504185fb |
302 | } |
303 | |
304 | for (my $i = 0; $i < $new_size; $i++) { |
305 | $self->STORE( $i, $new_elements[$i] ); |
306 | } |
8f6d6ed0 |
307 | |
9281d66b |
308 | $self->unlock; |
309 | |
8f6d6ed0 |
310 | return $length + $new_size; |
6fe26b29 |
311 | } |
312 | |
313 | sub SPLICE { |
2ac02042 |
314 | my $self = shift->_get_self; |
9281d66b |
315 | |
5c0756fc |
316 | $self->lock_exclusive; |
9281d66b |
317 | |
504185fb |
318 | my $length = $self->FETCHSIZE(); |
319 | |
320 | ## |
321 | # Calculate offset and length of splice |
322 | ## |
323 | my $offset = shift; |
714618f0 |
324 | $offset = 0 unless defined $offset; |
504185fb |
325 | if ($offset < 0) { $offset += $length; } |
326 | |
327 | my $splice_length; |
328 | if (scalar @_) { $splice_length = shift; } |
329 | else { $splice_length = $length - $offset; } |
330 | if ($splice_length < 0) { $splice_length += ($length - $offset); } |
331 | |
332 | ## |
333 | # Setup array with new elements, and copy out old elements for return |
334 | ## |
335 | my @new_elements = @_; |
336 | my $new_size = scalar @new_elements; |
337 | |
df3c5701 |
338 | my @old_elements = map { |
339 | $self->FETCH( $_ ) |
340 | } $offset .. ($offset + $splice_length - 1); |
504185fb |
341 | |
342 | ## |
343 | # Adjust array length, and shift elements to accomodate new section. |
344 | ## |
6fe26b29 |
345 | if ( $new_size != $splice_length ) { |
346 | if ($new_size > $splice_length) { |
347 | for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { |
807f63a7 |
348 | $self->_move_value( $i, $i + ($new_size - $splice_length) ); |
6fe26b29 |
349 | } |
1cff45d7 |
350 | $self->STORESIZE( $length + $new_size - $splice_length ); |
6fe26b29 |
351 | } |
352 | else { |
353 | for (my $i = $offset + $splice_length; $i < $length; $i++) { |
807f63a7 |
354 | $self->_move_value( $i, $i + ($new_size - $splice_length) ); |
6fe26b29 |
355 | } |
356 | for (my $i = 0; $i < $splice_length - $new_size; $i++) { |
357 | $self->DELETE( $length - 1 ); |
358 | $length--; |
359 | } |
360 | } |
504185fb |
361 | } |
362 | |
363 | ## |
364 | # Insert new elements into array |
365 | ## |
366 | for (my $i = $offset; $i < $offset + $new_size; $i++) { |
367 | $self->STORE( $i, shift @new_elements ); |
368 | } |
369 | |
9281d66b |
370 | $self->unlock; |
371 | |
504185fb |
372 | ## |
373 | # Return deleted section, or last element in scalar context. |
374 | ## |
375 | return wantarray ? @old_elements : $old_elements[-1]; |
6fe26b29 |
376 | } |
377 | |
2120a181 |
378 | # We don't need to populate it, yet. |
460b1067 |
379 | # It will be useful, though, when we split out HASH and ARRAY |
d426259c |
380 | # Perl will call EXTEND() when the array is likely to grow. |
381 | # We don't care, but include it because it gets called at times. |
382 | sub EXTEND {} |
6fe26b29 |
383 | |
f9c33187 |
384 | sub _copy_node { |
898fd1fd |
385 | my $self = shift; |
f9c33187 |
386 | my ($db_temp) = @_; |
387 | |
388 | my $length = $self->length(); |
389 | for (my $index = 0; $index < $length; $index++) { |
edd45134 |
390 | $self->_copy_value( \$db_temp->[$index], $self->get($index) ); |
f9c33187 |
391 | } |
392 | |
393 | return 1; |
394 | } |
395 | |
cd5303b4 |
396 | sub _clear { |
397 | my $self = shift; |
398 | |
399 | my $size = $self->FETCHSIZE; |
400 | for my $key ( 0 .. $size - 1 ) { |
401 | $self->_engine->delete_key( $self, $key, $key ); |
402 | } |
403 | $self->STORESIZE( 0 ); |
404 | |
405 | return; |
406 | } |
407 | |
d426259c |
408 | sub length { (shift)->FETCHSIZE(@_) } |
409 | sub pop { (shift)->POP(@_) } |
410 | sub push { (shift)->PUSH(@_) } |
411 | sub unshift { (shift)->UNSHIFT(@_) } |
412 | sub splice { (shift)->SPLICE(@_) } |
f9c33187 |
413 | |
414 | # This must be last otherwise we have to qualify all other calls to shift |
415 | # as calls to CORE::shift |
f75b719e |
416 | sub shift { (CORE::shift)->SHIFT(@_) } |
6fe26b29 |
417 | |
418 | 1; |
419 | __END__ |