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