1 package DBM::Deep::Array;
5 use vars qw( $NEGATIVE_INDICES );
13 eval { tied( @{$_[0]} ) } || $_[0]
18 # Tied array constructor method, called by Perl's tie() function.
21 my $args = $class->_get_args( @_ );
23 $args->{type} = $class->TYPE_ARRAY;
25 return $class->_init($args);
29 my $self = $_[0]->_get_self;
32 $self->lock( $self->LOCK_SH );
34 if ( $key =~ /^-?\d+$/ ) {
36 $key += $self->FETCHSIZE;
37 unless ( $key >= 0 ) {
43 $key = pack($DBM::Deep::LONG_PACK, $key);
46 my $rv = $self->SUPER::FETCH( $key );
54 my $self = shift->_get_self;
55 my ($key, $value) = @_;
57 $self->lock( $self->LOCK_EX );
60 my $size = $self->FETCHSIZE;
63 if ( $key =~ /^-?\d+$/ ) {
68 die( "Modification of non-creatable array value attempted, subscript $orig" );
72 $key = pack($DBM::Deep::LONG_PACK, $key);
75 my $rv = $self->SUPER::STORE( $key, $value );
77 if ( $numeric_idx && $rv == 2 && $orig >= $size ) {
78 $self->STORESIZE( $orig + 1 );
87 my $self = $_[0]->_get_self;
90 $self->lock( $self->LOCK_SH );
92 if ( $key =~ /^-?\d+$/ ) {
94 $key += $self->FETCHSIZE;
95 unless ( $key >= 0 ) {
101 $key = pack($DBM::Deep::LONG_PACK, $key);
104 my $rv = $self->SUPER::EXISTS( $key );
112 my $self = $_[0]->_get_self;
115 my $unpacked_key = $key;
117 $self->lock( $self->LOCK_EX );
119 my $size = $self->FETCHSIZE;
120 if ( $key =~ /^-?\d+$/ ) {
123 unless ( $key >= 0 ) {
129 $key = pack($DBM::Deep::LONG_PACK, $key);
132 my $rv = $self->SUPER::DELETE( $key );
134 if ($rv && $unpacked_key == $size - 1) {
135 $self->STORESIZE( $unpacked_key );
145 # Return the length of the array
147 my $self = shift->_get_self;
149 $self->lock( $self->LOCK_SH );
151 my $SAVE_FILTER = $self->root->{filter_fetch_value};
152 $self->root->{filter_fetch_value} = undef;
154 my $packed_size = $self->FETCH('length');
156 $self->root->{filter_fetch_value} = $SAVE_FILTER;
161 return int(unpack($DBM::Deep::LONG_PACK, $packed_size));
169 # Set the length of the array
171 my $self = $_[0]->_get_self;
172 my $new_length = $_[1];
174 $self->lock( $self->LOCK_EX );
176 my $SAVE_FILTER = $self->root->{filter_store_value};
177 $self->root->{filter_store_value} = undef;
179 my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
181 $self->root->{filter_store_value} = $SAVE_FILTER;
190 # Remove and return the last element on the array
192 my $self = $_[0]->_get_self;
194 $self->lock( $self->LOCK_EX );
196 my $length = $self->FETCHSIZE();
199 my $content = $self->FETCH( $length - 1 );
200 $self->DELETE( $length - 1 );
214 # Add new element(s) to the end of the array
216 my $self = shift->_get_self;
218 $self->lock( $self->LOCK_EX );
220 my $length = $self->FETCHSIZE();
222 while (my $content = shift @_) {
223 $self->STORE( $length, $content );
234 # Remove and return first element on the array.
235 # Shift over remaining elements to take up space.
237 my $self = $_[0]->_get_self;
239 $self->lock( $self->LOCK_EX );
241 my $length = $self->FETCHSIZE();
244 my $content = $self->FETCH( 0 );
247 # Shift elements over and remove last one.
249 for (my $i = 0; $i < $length - 1; $i++) {
250 $self->STORE( $i, $self->FETCH($i + 1) );
252 $self->DELETE( $length - 1 );
266 # Insert new element(s) at beginning of array.
267 # Shift over other elements to make space.
269 my $self = shift->_get_self;
270 my @new_elements = @_;
272 $self->lock( $self->LOCK_EX );
274 my $length = $self->FETCHSIZE();
275 my $new_size = scalar @new_elements;
278 for (my $i = $length - 1; $i >= 0; $i--) {
279 $self->STORE( $i + $new_size, $self->FETCH($i) );
283 for (my $i = 0; $i < $new_size; $i++) {
284 $self->STORE( $i, $new_elements[$i] );
289 return $length + $new_size;
294 # Splices section of array with optional new section.
295 # Returns deleted section, or last element deleted in scalar context.
297 my $self = shift->_get_self;
299 $self->lock( $self->LOCK_EX );
301 my $length = $self->FETCHSIZE();
304 # Calculate offset and length of splice
306 my $offset = shift || 0;
307 if ($offset < 0) { $offset += $length; }
310 if (scalar @_) { $splice_length = shift; }
311 else { $splice_length = $length - $offset; }
312 if ($splice_length < 0) { $splice_length += ($length - $offset); }
315 # Setup array with new elements, and copy out old elements for return
317 my @new_elements = @_;
318 my $new_size = scalar @new_elements;
320 my @old_elements = ();
321 for (my $i = $offset; $i < $offset + $splice_length; $i++) {
322 push @old_elements, $self->FETCH( $i );
326 # Adjust array length, and shift elements to accomodate new section.
328 if ( $new_size != $splice_length ) {
329 if ($new_size > $splice_length) {
330 for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
331 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
335 for (my $i = $offset + $splice_length; $i < $length; $i++) {
336 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
338 for (my $i = 0; $i < $splice_length - $new_size; $i++) {
339 $self->DELETE( $length - 1 );
346 # Insert new elements into array
348 for (my $i = $offset; $i < $offset + $new_size; $i++) {
349 $self->STORE( $i, shift @new_elements );
355 # Return deleted section, or last element in scalar context.
357 return wantarray ? @old_elements : $old_elements[-1];
360 #XXX We don't need to define it, yet.
361 #XXX It will be useful, though, when we split out HASH and ARRAY
364 # Perl will call EXTEND() when the array is likely to grow.
365 # We don't care, but include it for compatibility.
370 # Public method aliases
372 *length = *FETCHSIZE;