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