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