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