Commit | Line | Data |
6fe26b29 |
1 | package DBM::Deep::Array; |
2 | |
3 | use strict; |
4 | |
8fec41b9 |
5 | # This is to allow DBM::Deep::Array to handle negative indices on |
6 | # its own. Otherwise, Perl would intercept the call to negative |
7 | # indices for us. This was causing bugs for negative index handling. |
7910cf68 |
8 | use vars qw( $NEGATIVE_INDICES ); |
9 | $NEGATIVE_INDICES = 1; |
10 | |
6fe26b29 |
11 | use base 'DBM::Deep'; |
12 | |
e1b265cc |
13 | use Scalar::Util (); |
14 | |
596e9574 |
15 | sub _get_self { |
8db25060 |
16 | eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] |
596e9574 |
17 | } |
18 | |
f9c33187 |
19 | sub _repr { shift;[ @_ ] } |
20 | |
21 | sub _import { |
22 | my $self = shift; |
23 | my ($struct) = @_; |
24 | |
25 | eval { |
26 | local $SIG{'__DIE__'}; |
27 | $self->push( @$struct ); |
28 | }; if ($@) { |
29 | $self->_throw_error("Cannot import: type mismatch"); |
30 | } |
31 | |
32 | return 1; |
33 | } |
6fe26b29 |
34 | sub TIEARRAY { |
35 | ## |
36 | # Tied array constructor method, called by Perl's tie() function. |
37 | ## |
38 | my $class = shift; |
0ca7ea98 |
39 | my $args = $class->_get_args( @_ ); |
6fe26b29 |
40 | |
41 | $args->{type} = $class->TYPE_ARRAY; |
42 | |
43 | return $class->_init($args); |
44 | } |
45 | |
7f441181 |
46 | sub FETCH { |
eea0d863 |
47 | my $self = shift->_get_self; |
48 | my ($key) = @_; |
7f441181 |
49 | |
9281d66b |
50 | $self->lock( $self->LOCK_SH ); |
9a187d8c |
51 | |
7f441181 |
52 | if ( $key =~ /^-?\d+$/ ) { |
53 | if ( $key < 0 ) { |
54 | $key += $self->FETCHSIZE; |
9281d66b |
55 | unless ( $key >= 0 ) { |
56 | $self->unlock; |
57 | return; |
58 | } |
7f441181 |
59 | } |
60 | |
612969fb |
61 | $key = pack($self->{engine}{long_pack}, $key); |
7f441181 |
62 | } |
63 | |
9281d66b |
64 | my $rv = $self->SUPER::FETCH( $key ); |
65 | |
66 | $self->unlock; |
67 | |
68 | return $rv; |
7f441181 |
69 | } |
70 | |
cb79ec85 |
71 | sub STORE { |
72 | my $self = shift->_get_self; |
73 | my ($key, $value) = @_; |
74 | |
9281d66b |
75 | $self->lock( $self->LOCK_EX ); |
76 | |
baa27ab6 |
77 | my $orig = $key; |
cb79ec85 |
78 | |
9ab67b8c |
79 | my $size; |
cb79ec85 |
80 | my $numeric_idx; |
9ab67b8c |
81 | if ( $key =~ /^\-?\d+$/ ) { |
cb79ec85 |
82 | $numeric_idx = 1; |
83 | if ( $key < 0 ) { |
9ab67b8c |
84 | $size = $self->FETCHSIZE; |
cb79ec85 |
85 | $key += $size; |
baa27ab6 |
86 | if ( $key < 0 ) { |
87 | die( "Modification of non-creatable array value attempted, subscript $orig" ); |
88 | } |
cb79ec85 |
89 | } |
90 | |
612969fb |
91 | $key = pack($self->{engine}{long_pack}, $key); |
cb79ec85 |
92 | } |
93 | |
94 | my $rv = $self->SUPER::STORE( $key, $value ); |
95 | |
9ab67b8c |
96 | if ( $numeric_idx && $rv == 2 ) { |
97 | $size = $self->FETCHSIZE unless defined $size; |
98 | if ( $orig >= $size ) { |
99 | $self->STORESIZE( $orig + 1 ); |
100 | } |
cb79ec85 |
101 | } |
102 | |
9281d66b |
103 | $self->unlock; |
104 | |
cb79ec85 |
105 | return $rv; |
106 | } |
107 | |
baa27ab6 |
108 | sub EXISTS { |
eea0d863 |
109 | my $self = shift->_get_self; |
110 | my ($key) = @_; |
baa27ab6 |
111 | |
9281d66b |
112 | $self->lock( $self->LOCK_SH ); |
113 | |
9ab67b8c |
114 | if ( $key =~ /^\-?\d+$/ ) { |
baa27ab6 |
115 | if ( $key < 0 ) { |
116 | $key += $self->FETCHSIZE; |
9281d66b |
117 | unless ( $key >= 0 ) { |
118 | $self->unlock; |
119 | return; |
120 | } |
121 | } |
122 | |
612969fb |
123 | $key = pack($self->{engine}{long_pack}, $key); |
9281d66b |
124 | } |
125 | |
126 | my $rv = $self->SUPER::EXISTS( $key ); |
127 | |
128 | $self->unlock; |
129 | |
130 | return $rv; |
131 | } |
132 | |
133 | sub DELETE { |
eea0d863 |
134 | my $self = shift->_get_self; |
135 | my ($key) = @_; |
9281d66b |
136 | |
137 | my $unpacked_key = $key; |
138 | |
139 | $self->lock( $self->LOCK_EX ); |
140 | |
141 | my $size = $self->FETCHSIZE; |
142 | if ( $key =~ /^-?\d+$/ ) { |
143 | if ( $key < 0 ) { |
144 | $key += $size; |
145 | unless ( $key >= 0 ) { |
146 | $self->unlock; |
147 | return; |
148 | } |
baa27ab6 |
149 | } |
150 | |
612969fb |
151 | $key = pack($self->{engine}{long_pack}, $key); |
baa27ab6 |
152 | } |
153 | |
9281d66b |
154 | my $rv = $self->SUPER::DELETE( $key ); |
155 | |
156 | if ($rv && $unpacked_key == $size - 1) { |
157 | $self->STORESIZE( $unpacked_key ); |
158 | } |
159 | |
160 | $self->unlock; |
161 | |
162 | return $rv; |
baa27ab6 |
163 | } |
164 | |
6fe26b29 |
165 | sub FETCHSIZE { |
166 | ## |
167 | # Return the length of the array |
168 | ## |
9281d66b |
169 | my $self = shift->_get_self; |
170 | |
171 | $self->lock( $self->LOCK_SH ); |
172 | |
4d35d856 |
173 | my $SAVE_FILTER = $self->_root->{filter_fetch_value}; |
174 | $self->_root->{filter_fetch_value} = undef; |
6fe26b29 |
175 | |
176 | my $packed_size = $self->FETCH('length'); |
177 | |
4d35d856 |
178 | $self->_root->{filter_fetch_value} = $SAVE_FILTER; |
6fe26b29 |
179 | |
9281d66b |
180 | $self->unlock; |
181 | |
7f441181 |
182 | if ($packed_size) { |
612969fb |
183 | return int(unpack($self->{engine}{long_pack}, $packed_size)); |
7f441181 |
184 | } |
cb79ec85 |
185 | |
186 | return 0; |
6fe26b29 |
187 | } |
188 | |
189 | sub STORESIZE { |
190 | ## |
191 | # Set the length of the array |
192 | ## |
eea0d863 |
193 | my $self = shift->_get_self; |
194 | my ($new_length) = @_; |
6fe26b29 |
195 | |
9281d66b |
196 | $self->lock( $self->LOCK_EX ); |
197 | |
4d35d856 |
198 | my $SAVE_FILTER = $self->_root->{filter_store_value}; |
199 | $self->_root->{filter_store_value} = undef; |
6fe26b29 |
200 | |
612969fb |
201 | my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length)); |
6fe26b29 |
202 | |
4d35d856 |
203 | $self->_root->{filter_store_value} = $SAVE_FILTER; |
6fe26b29 |
204 | |
9281d66b |
205 | $self->unlock; |
206 | |
6fe26b29 |
207 | return $result; |
208 | } |
209 | |
210 | sub POP { |
211 | ## |
212 | # Remove and return the last element on the array |
213 | ## |
eea0d863 |
214 | my $self = shift->_get_self; |
9281d66b |
215 | |
216 | $self->lock( $self->LOCK_EX ); |
217 | |
6fe26b29 |
218 | my $length = $self->FETCHSIZE(); |
219 | |
220 | if ($length) { |
221 | my $content = $self->FETCH( $length - 1 ); |
222 | $self->DELETE( $length - 1 ); |
9281d66b |
223 | |
224 | $self->unlock; |
225 | |
6fe26b29 |
226 | return $content; |
227 | } |
228 | else { |
9281d66b |
229 | $self->unlock; |
6fe26b29 |
230 | return; |
231 | } |
232 | } |
233 | |
234 | sub PUSH { |
235 | ## |
236 | # Add new element(s) to the end of the array |
237 | ## |
2ac02042 |
238 | my $self = shift->_get_self; |
6fe26b29 |
239 | |
9281d66b |
240 | $self->lock( $self->LOCK_EX ); |
241 | |
242 | my $length = $self->FETCHSIZE(); |
243 | |
6fe26b29 |
244 | while (my $content = shift @_) { |
245 | $self->STORE( $length, $content ); |
246 | $length++; |
247 | } |
8f6d6ed0 |
248 | |
9281d66b |
249 | $self->unlock; |
250 | |
8f6d6ed0 |
251 | return $length; |
6fe26b29 |
252 | } |
253 | |
254 | sub SHIFT { |
255 | ## |
256 | # Remove and return first element on the array. |
257 | # Shift over remaining elements to take up space. |
258 | ## |
eea0d863 |
259 | my $self = shift->_get_self; |
9281d66b |
260 | |
261 | $self->lock( $self->LOCK_EX ); |
262 | |
6fe26b29 |
263 | my $length = $self->FETCHSIZE(); |
264 | |
265 | if ($length) { |
266 | my $content = $self->FETCH( 0 ); |
267 | |
268 | ## |
269 | # Shift elements over and remove last one. |
270 | ## |
271 | for (my $i = 0; $i < $length - 1; $i++) { |
272 | $self->STORE( $i, $self->FETCH($i + 1) ); |
273 | } |
274 | $self->DELETE( $length - 1 ); |
9281d66b |
275 | |
276 | $self->unlock; |
6fe26b29 |
277 | |
278 | return $content; |
279 | } |
280 | else { |
9281d66b |
281 | $self->unlock; |
6fe26b29 |
282 | return; |
283 | } |
284 | } |
285 | |
286 | sub UNSHIFT { |
287 | ## |
288 | # Insert new element(s) at beginning of array. |
289 | # Shift over other elements to make space. |
290 | ## |
2ac02042 |
291 | my $self = shift->_get_self; |
6fe26b29 |
292 | my @new_elements = @_; |
9281d66b |
293 | |
294 | $self->lock( $self->LOCK_EX ); |
295 | |
6fe26b29 |
296 | my $length = $self->FETCHSIZE(); |
297 | my $new_size = scalar @new_elements; |
298 | |
299 | if ($length) { |
300 | for (my $i = $length - 1; $i >= 0; $i--) { |
301 | $self->STORE( $i + $new_size, $self->FETCH($i) ); |
302 | } |
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 { |
315 | ## |
316 | # Splices section of array with optional new section. |
317 | # Returns deleted section, or last element deleted in scalar context. |
318 | ## |
2ac02042 |
319 | my $self = shift->_get_self; |
9281d66b |
320 | |
321 | $self->lock( $self->LOCK_EX ); |
322 | |
6fe26b29 |
323 | my $length = $self->FETCHSIZE(); |
324 | |
325 | ## |
326 | # Calculate offset and length of splice |
327 | ## |
714618f0 |
328 | my $offset = shift; |
329 | $offset = 0 unless defined $offset; |
6fe26b29 |
330 | if ($offset < 0) { $offset += $length; } |
331 | |
332 | my $splice_length; |
333 | if (scalar @_) { $splice_length = shift; } |
334 | else { $splice_length = $length - $offset; } |
335 | if ($splice_length < 0) { $splice_length += ($length - $offset); } |
336 | |
337 | ## |
338 | # Setup array with new elements, and copy out old elements for return |
339 | ## |
340 | my @new_elements = @_; |
341 | my $new_size = scalar @new_elements; |
342 | |
df3c5701 |
343 | my @old_elements = map { |
344 | $self->FETCH( $_ ) |
345 | } $offset .. ($offset + $splice_length - 1); |
6fe26b29 |
346 | |
347 | ## |
348 | # Adjust array length, and shift elements to accomodate new section. |
349 | ## |
350 | if ( $new_size != $splice_length ) { |
351 | if ($new_size > $splice_length) { |
352 | for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { |
353 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
354 | } |
355 | } |
356 | else { |
357 | for (my $i = $offset + $splice_length; $i < $length; $i++) { |
358 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
359 | } |
360 | for (my $i = 0; $i < $splice_length - $new_size; $i++) { |
361 | $self->DELETE( $length - 1 ); |
362 | $length--; |
363 | } |
364 | } |
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 | |
6fe26b29 |
376 | ## |
377 | # Return deleted section, or last element in scalar context. |
378 | ## |
379 | return wantarray ? @old_elements : $old_elements[-1]; |
380 | } |
381 | |
9281d66b |
382 | #XXX We don't need to define it, yet. |
6fe26b29 |
383 | #XXX It will be useful, though, when we split out HASH and ARRAY |
384 | #sub EXTEND { |
385 | ## |
386 | # Perl will call EXTEND() when the array is likely to grow. |
387 | # We don't care, but include it for compatibility. |
388 | ## |
389 | #} |
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__ |