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