1 package DBM::Deep::Array;
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 );
16 #eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
17 eval { tied( @{$_[0]} ) } || $_[0]
22 # Tied array constructor method, called by Perl's tie() function.
25 my $args = $class->_get_args( @_ );
27 $args->{type} = $class->TYPE_ARRAY;
29 return $class->_init($args);
33 my $self = $_[0]->_get_self;
36 $self->lock( $self->LOCK_SH );
38 if ( $key =~ /^-?\d+$/ ) {
40 $key += $self->FETCHSIZE;
41 unless ( $key >= 0 ) {
47 $key = pack($self->{engine}{long_pack}, $key);
50 my $rv = $self->SUPER::FETCH( $key );
58 my $self = shift->_get_self;
59 my ($key, $value) = @_;
61 $self->lock( $self->LOCK_EX );
67 if ( $key =~ /^\-?\d+$/ ) {
70 $size = $self->FETCHSIZE;
73 die( "Modification of non-creatable array value attempted, subscript $orig" );
77 $key = pack($self->{engine}{long_pack}, $key);
80 my $rv = $self->SUPER::STORE( $key, $value );
82 if ( $numeric_idx && $rv == 2 ) {
83 $size = $self->FETCHSIZE unless defined $size;
84 if ( $orig >= $size ) {
85 $self->STORESIZE( $orig + 1 );
95 my $self = $_[0]->_get_self;
98 $self->lock( $self->LOCK_SH );
100 if ( $key =~ /^\-?\d+$/ ) {
102 $key += $self->FETCHSIZE;
103 unless ( $key >= 0 ) {
109 $key = pack($self->{engine}{long_pack}, $key);
112 my $rv = $self->SUPER::EXISTS( $key );
120 my $self = $_[0]->_get_self;
123 my $unpacked_key = $key;
125 $self->lock( $self->LOCK_EX );
127 my $size = $self->FETCHSIZE;
128 if ( $key =~ /^-?\d+$/ ) {
131 unless ( $key >= 0 ) {
137 $key = pack($self->{engine}{long_pack}, $key);
140 my $rv = $self->SUPER::DELETE( $key );
142 if ($rv && $unpacked_key == $size - 1) {
143 $self->STORESIZE( $unpacked_key );
153 # Return the length of the array
155 my $self = shift->_get_self;
157 $self->lock( $self->LOCK_SH );
159 my $SAVE_FILTER = $self->_root->{filter_fetch_value};
160 $self->_root->{filter_fetch_value} = undef;
162 my $packed_size = $self->FETCH('length');
164 $self->_root->{filter_fetch_value} = $SAVE_FILTER;
169 return int(unpack($self->{engine}{long_pack}, $packed_size));
177 # Set the length of the array
179 my $self = $_[0]->_get_self;
180 my $new_length = $_[1];
182 $self->lock( $self->LOCK_EX );
184 my $SAVE_FILTER = $self->_root->{filter_store_value};
185 $self->_root->{filter_store_value} = undef;
187 my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
189 $self->_root->{filter_store_value} = $SAVE_FILTER;
198 # Remove and return the last element on the array
200 my $self = $_[0]->_get_self;
202 $self->lock( $self->LOCK_EX );
204 my $length = $self->FETCHSIZE();
207 my $content = $self->FETCH( $length - 1 );
208 $self->DELETE( $length - 1 );
222 # Add new element(s) to the end of the array
224 my $self = shift->_get_self;
226 $self->lock( $self->LOCK_EX );
228 my $length = $self->FETCHSIZE();
230 while (my $content = shift @_) {
231 $self->STORE( $length, $content );
242 # Remove and return first element on the array.
243 # Shift over remaining elements to take up space.
245 my $self = $_[0]->_get_self;
247 $self->lock( $self->LOCK_EX );
249 my $length = $self->FETCHSIZE();
252 my $content = $self->FETCH( 0 );
255 # Shift elements over and remove last one.
257 for (my $i = 0; $i < $length - 1; $i++) {
258 $self->STORE( $i, $self->FETCH($i + 1) );
260 $self->DELETE( $length - 1 );
274 # Insert new element(s) at beginning of array.
275 # Shift over other elements to make space.
277 my $self = shift->_get_self;
278 my @new_elements = @_;
280 $self->lock( $self->LOCK_EX );
282 my $length = $self->FETCHSIZE();
283 my $new_size = scalar @new_elements;
286 for (my $i = $length - 1; $i >= 0; $i--) {
287 $self->STORE( $i + $new_size, $self->FETCH($i) );
291 for (my $i = 0; $i < $new_size; $i++) {
292 $self->STORE( $i, $new_elements[$i] );
297 return $length + $new_size;
302 # Splices section of array with optional new section.
303 # Returns deleted section, or last element deleted in scalar context.
305 my $self = shift->_get_self;
307 $self->lock( $self->LOCK_EX );
309 my $length = $self->FETCHSIZE();
312 # Calculate offset and length of splice
315 $offset = 0 unless defined $offset;
316 if ($offset < 0) { $offset += $length; }
319 if (scalar @_) { $splice_length = shift; }
320 else { $splice_length = $length - $offset; }
321 if ($splice_length < 0) { $splice_length += ($length - $offset); }
324 # Setup array with new elements, and copy out old elements for return
326 my @new_elements = @_;
327 my $new_size = scalar @new_elements;
329 my @old_elements = map {
331 } $offset .. ($offset + $splice_length - 1);
334 # Adjust array length, and shift elements to accomodate new section.
336 if ( $new_size != $splice_length ) {
337 if ($new_size > $splice_length) {
338 for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
339 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
343 for (my $i = $offset + $splice_length; $i < $length; $i++) {
344 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
346 for (my $i = 0; $i < $splice_length - $new_size; $i++) {
347 $self->DELETE( $length - 1 );
354 # Insert new elements into array
356 for (my $i = $offset; $i < $offset + $new_size; $i++) {
357 $self->STORE( $i, shift @new_elements );
363 # Return deleted section, or last element in scalar context.
365 return wantarray ? @old_elements : $old_elements[-1];
368 #XXX We don't need to define it, yet.
369 #XXX It will be useful, though, when we split out HASH and ARRAY
372 # Perl will call EXTEND() when the array is likely to grow.
373 # We don't care, but include it for compatibility.
378 # Public method aliases
380 sub length { (CORE::shift)->FETCHSIZE(@_) }
381 sub pop { (CORE::shift)->POP(@_) }
382 sub push { (CORE::shift)->PUSH(@_) }
383 sub shift { (CORE::shift)->SHIFT(@_) }
384 sub unshift { (CORE::shift)->UNSHIFT(@_) }
385 sub splice { (CORE::shift)->SPLICE(@_) }