Commit | Line | Data |
6fe26b29 |
1 | package DBM::Deep::Array; |
2 | |
460b1067 |
3 | use 5.6.0; |
4 | |
6fe26b29 |
5 | use strict; |
460b1067 |
6 | use warnings; |
6fe26b29 |
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 | |
f9c33187 |
21 | sub _repr { shift;[ @_ ] } |
22 | |
23 | sub _import { |
24 | my $self = shift; |
25 | my ($struct) = @_; |
26 | |
27 | eval { |
28 | local $SIG{'__DIE__'}; |
29 | $self->push( @$struct ); |
30 | }; if ($@) { |
31 | $self->_throw_error("Cannot import: type mismatch"); |
32 | } |
33 | |
34 | return 1; |
35 | } |
6fe26b29 |
36 | sub TIEARRAY { |
6fe26b29 |
37 | my $class = shift; |
0ca7ea98 |
38 | my $args = $class->_get_args( @_ ); |
504185fb |
39 | |
40 | $args->{type} = $class->TYPE_ARRAY; |
41 | |
42 | return $class->_init($args); |
6fe26b29 |
43 | } |
44 | |
7f441181 |
45 | sub FETCH { |
eea0d863 |
46 | my $self = shift->_get_self; |
47 | my ($key) = @_; |
7f441181 |
48 | |
504185fb |
49 | $self->lock( $self->LOCK_SH ); |
9a187d8c |
50 | |
504185fb |
51 | # my $orig_key = $key eq 'length' ? undef : $key; |
52 | my $orig_key = $key; |
7f441181 |
53 | if ( $key =~ /^-?\d+$/ ) { |
54 | if ( $key < 0 ) { |
55 | $key += $self->FETCHSIZE; |
9281d66b |
56 | unless ( $key >= 0 ) { |
57 | $self->unlock; |
58 | return; |
59 | } |
7f441181 |
60 | } |
61 | |
612969fb |
62 | $key = pack($self->{engine}{long_pack}, $key); |
7f441181 |
63 | } |
64 | |
cfd97a7f |
65 | my $rv = $self->SUPER::FETCH( $key, $orig_key ); |
9281d66b |
66 | |
67 | $self->unlock; |
68 | |
69 | return $rv; |
7f441181 |
70 | } |
71 | |
cb79ec85 |
72 | sub STORE { |
73 | my $self = shift->_get_self; |
74 | my ($key, $value) = @_; |
75 | |
9281d66b |
76 | $self->lock( $self->LOCK_EX ); |
77 | |
504185fb |
78 | # my $orig = $key eq 'length' ? undef : $key; |
79 | my $orig_key = $key; |
cb79ec85 |
80 | |
9ab67b8c |
81 | my $size; |
cb79ec85 |
82 | my $numeric_idx; |
9ab67b8c |
83 | if ( $key =~ /^\-?\d+$/ ) { |
cb79ec85 |
84 | $numeric_idx = 1; |
85 | if ( $key < 0 ) { |
9ab67b8c |
86 | $size = $self->FETCHSIZE; |
cb79ec85 |
87 | $key += $size; |
baa27ab6 |
88 | if ( $key < 0 ) { |
504185fb |
89 | die( "Modification of non-creatable array value attempted, subscript $orig_key" ); |
baa27ab6 |
90 | } |
cb79ec85 |
91 | } |
92 | |
612969fb |
93 | $key = pack($self->{engine}{long_pack}, $key); |
cb79ec85 |
94 | } |
95 | |
504185fb |
96 | my $rv = $self->SUPER::STORE( $key, $value, $orig_key ); |
cb79ec85 |
97 | |
9ab67b8c |
98 | if ( $numeric_idx && $rv == 2 ) { |
99 | $size = $self->FETCHSIZE unless defined $size; |
504185fb |
100 | if ( $orig_key >= $size ) { |
101 | $self->STORESIZE( $orig_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) = @_; |
baa27ab6 |
113 | |
504185fb |
114 | $self->lock( $self->LOCK_SH ); |
9281d66b |
115 | |
9ab67b8c |
116 | if ( $key =~ /^\-?\d+$/ ) { |
baa27ab6 |
117 | if ( $key < 0 ) { |
118 | $key += $self->FETCHSIZE; |
9281d66b |
119 | unless ( $key >= 0 ) { |
120 | $self->unlock; |
121 | return; |
122 | } |
123 | } |
124 | |
612969fb |
125 | $key = pack($self->{engine}{long_pack}, $key); |
9281d66b |
126 | } |
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) = @_; |
9281d66b |
138 | |
139 | my $unpacked_key = $key; |
a97c8f67 |
140 | my $orig = $key eq 'length' ? undef : $key; |
9281d66b |
141 | |
142 | $self->lock( $self->LOCK_EX ); |
143 | |
144 | my $size = $self->FETCHSIZE; |
145 | if ( $key =~ /^-?\d+$/ ) { |
146 | if ( $key < 0 ) { |
147 | $key += $size; |
148 | unless ( $key >= 0 ) { |
149 | $self->unlock; |
150 | return; |
151 | } |
baa27ab6 |
152 | } |
153 | |
612969fb |
154 | $key = pack($self->{engine}{long_pack}, $key); |
baa27ab6 |
155 | } |
156 | |
a97c8f67 |
157 | my $rv = $self->SUPER::DELETE( $key, $orig ); |
9281d66b |
158 | |
504185fb |
159 | if ($rv && $unpacked_key == $size - 1) { |
160 | $self->STORESIZE( $unpacked_key ); |
161 | } |
9281d66b |
162 | |
163 | $self->unlock; |
164 | |
165 | return $rv; |
baa27ab6 |
166 | } |
167 | |
6fe26b29 |
168 | sub FETCHSIZE { |
9281d66b |
169 | my $self = shift->_get_self; |
170 | |
171 | $self->lock( $self->LOCK_SH ); |
172 | |
504185fb |
173 | my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value}; |
174 | $self->_fileobj->{filter_fetch_value} = undef; |
175 | |
176 | my $packed_size = $self->FETCH('length'); |
177 | |
178 | $self->_fileobj->{filter_fetch_value} = $SAVE_FILTER; |
179 | |
9281d66b |
180 | $self->unlock; |
181 | |
504185fb |
182 | if ($packed_size) { |
612969fb |
183 | return int(unpack($self->{engine}{long_pack}, $packed_size)); |
7f441181 |
184 | } |
cb79ec85 |
185 | |
504185fb |
186 | return 0; |
6fe26b29 |
187 | } |
188 | |
189 | sub STORESIZE { |
eea0d863 |
190 | my $self = shift->_get_self; |
504185fb |
191 | my ($new_length) = @_; |
192 | |
9281d66b |
193 | $self->lock( $self->LOCK_EX ); |
194 | |
504185fb |
195 | my $SAVE_FILTER = $self->_fileobj->{filter_store_value}; |
196 | $self->_fileobj->{filter_store_value} = undef; |
197 | |
198 | my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length), 'length'); |
199 | |
200 | $self->_fileobj->{filter_store_value} = $SAVE_FILTER; |
201 | |
9281d66b |
202 | $self->unlock; |
203 | |
504185fb |
204 | return $result; |
6fe26b29 |
205 | } |
206 | |
207 | sub POP { |
eea0d863 |
208 | my $self = shift->_get_self; |
9281d66b |
209 | |
210 | $self->lock( $self->LOCK_EX ); |
211 | |
504185fb |
212 | my $length = $self->FETCHSIZE(); |
213 | |
214 | if ($length) { |
215 | my $content = $self->FETCH( $length - 1 ); |
216 | $self->DELETE( $length - 1 ); |
9281d66b |
217 | |
218 | $self->unlock; |
219 | |
504185fb |
220 | return $content; |
221 | } |
222 | else { |
9281d66b |
223 | $self->unlock; |
504185fb |
224 | return; |
225 | } |
6fe26b29 |
226 | } |
227 | |
228 | sub PUSH { |
2ac02042 |
229 | my $self = shift->_get_self; |
504185fb |
230 | |
9281d66b |
231 | $self->lock( $self->LOCK_EX ); |
232 | |
504185fb |
233 | my $length = $self->FETCHSIZE(); |
9281d66b |
234 | |
504185fb |
235 | while (my $content = shift @_) { |
236 | $self->STORE( $length, $content ); |
237 | $length++; |
238 | } |
8f6d6ed0 |
239 | |
9281d66b |
240 | $self->unlock; |
241 | |
8f6d6ed0 |
242 | return $length; |
6fe26b29 |
243 | } |
244 | |
245 | sub SHIFT { |
eea0d863 |
246 | my $self = shift->_get_self; |
9281d66b |
247 | |
248 | $self->lock( $self->LOCK_EX ); |
249 | |
504185fb |
250 | my $length = $self->FETCHSIZE(); |
251 | |
252 | if ($length) { |
253 | my $content = $self->FETCH( 0 ); |
254 | |
255 | for (my $i = 0; $i < $length - 1; $i++) { |
256 | $self->STORE( $i, $self->FETCH($i + 1) ); |
257 | } |
258 | $self->DELETE( $length - 1 ); |
9281d66b |
259 | |
260 | $self->unlock; |
504185fb |
261 | |
262 | return $content; |
263 | } |
264 | else { |
9281d66b |
265 | $self->unlock; |
504185fb |
266 | return; |
267 | } |
6fe26b29 |
268 | } |
269 | |
270 | sub UNSHIFT { |
2ac02042 |
271 | my $self = shift->_get_self; |
504185fb |
272 | my @new_elements = @_; |
9281d66b |
273 | |
274 | $self->lock( $self->LOCK_EX ); |
275 | |
504185fb |
276 | my $length = $self->FETCHSIZE(); |
277 | my $new_size = scalar @new_elements; |
278 | |
279 | if ($length) { |
280 | for (my $i = $length - 1; $i >= 0; $i--) { |
281 | $self->STORE( $i + $new_size, $self->FETCH($i) ); |
282 | } |
283 | } |
284 | |
285 | for (my $i = 0; $i < $new_size; $i++) { |
286 | $self->STORE( $i, $new_elements[$i] ); |
287 | } |
8f6d6ed0 |
288 | |
9281d66b |
289 | $self->unlock; |
290 | |
8f6d6ed0 |
291 | return $length + $new_size; |
6fe26b29 |
292 | } |
293 | |
294 | sub SPLICE { |
2ac02042 |
295 | my $self = shift->_get_self; |
9281d66b |
296 | |
297 | $self->lock( $self->LOCK_EX ); |
298 | |
504185fb |
299 | my $length = $self->FETCHSIZE(); |
300 | |
301 | ## |
302 | # Calculate offset and length of splice |
303 | ## |
304 | my $offset = shift; |
714618f0 |
305 | $offset = 0 unless defined $offset; |
504185fb |
306 | if ($offset < 0) { $offset += $length; } |
307 | |
308 | my $splice_length; |
309 | if (scalar @_) { $splice_length = shift; } |
310 | else { $splice_length = $length - $offset; } |
311 | if ($splice_length < 0) { $splice_length += ($length - $offset); } |
312 | |
313 | ## |
314 | # Setup array with new elements, and copy out old elements for return |
315 | ## |
316 | my @new_elements = @_; |
317 | my $new_size = scalar @new_elements; |
318 | |
df3c5701 |
319 | my @old_elements = map { |
320 | $self->FETCH( $_ ) |
321 | } $offset .. ($offset + $splice_length - 1); |
504185fb |
322 | |
323 | ## |
324 | # Adjust array length, and shift elements to accomodate new section. |
325 | ## |
6fe26b29 |
326 | if ( $new_size != $splice_length ) { |
327 | if ($new_size > $splice_length) { |
328 | for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { |
329 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
330 | } |
331 | } |
332 | else { |
333 | for (my $i = $offset + $splice_length; $i < $length; $i++) { |
334 | $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); |
335 | } |
336 | for (my $i = 0; $i < $splice_length - $new_size; $i++) { |
337 | $self->DELETE( $length - 1 ); |
338 | $length--; |
339 | } |
340 | } |
504185fb |
341 | } |
342 | |
343 | ## |
344 | # Insert new elements into array |
345 | ## |
346 | for (my $i = $offset; $i < $offset + $new_size; $i++) { |
347 | $self->STORE( $i, shift @new_elements ); |
348 | } |
349 | |
9281d66b |
350 | $self->unlock; |
351 | |
504185fb |
352 | ## |
353 | # Return deleted section, or last element in scalar context. |
354 | ## |
355 | return wantarray ? @old_elements : $old_elements[-1]; |
6fe26b29 |
356 | } |
357 | |
460b1067 |
358 | # We don't need to define it, yet. |
359 | # It will be useful, though, when we split out HASH and ARRAY |
685e40f1 |
360 | sub EXTEND { |
504185fb |
361 | ## |
362 | # Perl will call EXTEND() when the array is likely to grow. |
363 | # We don't care, but include it because it gets called at times. |
364 | ## |
685e40f1 |
365 | } |
6fe26b29 |
366 | |
f9c33187 |
367 | sub _copy_node { |
898fd1fd |
368 | my $self = shift; |
f9c33187 |
369 | my ($db_temp) = @_; |
370 | |
371 | my $length = $self->length(); |
372 | for (my $index = 0; $index < $length; $index++) { |
373 | my $value = $self->get($index); |
374 | $self->_copy_value( \$db_temp->[$index], $value ); |
375 | } |
376 | |
377 | return 1; |
378 | } |
379 | |
6fe26b29 |
380 | ## |
381 | # Public method aliases |
382 | ## |
f9c33187 |
383 | sub length { (shift)->FETCHSIZE(@_) } |
384 | sub pop { (shift)->POP(@_) } |
385 | sub push { (shift)->PUSH(@_) } |
386 | sub unshift { (shift)->UNSHIFT(@_) } |
387 | sub splice { (shift)->SPLICE(@_) } |
388 | |
389 | # This must be last otherwise we have to qualify all other calls to shift |
390 | # as calls to CORE::shift |
f75b719e |
391 | sub shift { (CORE::shift)->SHIFT(@_) } |
6fe26b29 |
392 | |
393 | 1; |
394 | __END__ |