1 package DBM::Deep::Array;
12 eval { tied( @{$_[0]} ) } || $_[0]
17 # Tied array constructor method, called by Perl's tie() function.
23 $class->_throw_error( "Odd number of parameters to TIEARRAY" );
27 elsif ( my $type = Scalar::Util::reftype($_[0]) ) {
28 if ( $type ne 'HASH' ) {
29 $class->_throw_error( "Not a hashref in TIEARRAY" );
34 $args = { file => shift };
37 $args->{type} = $class->TYPE_ARRAY;
39 return $class->_init($args);
43 my $self = $_[0]->_get_self;
46 if ( $key =~ /^-?\d+$/ ) {
48 $key += $self->FETCHSIZE;
49 return unless $key >= 0;
52 $key = pack($DBM::Deep::LONG_PACK, $key);
55 return $self->SUPER::FETCH( $key );
59 my $self = shift->_get_self;
60 my ($key, $value) = @_;
63 my $size = $self->FETCHSIZE;
66 if ( $key =~ /^-?\d+$/ ) {
71 die( "Modification of non-creatable array value attempted, subscript $orig" );
75 $key = pack($DBM::Deep::LONG_PACK, $key);
78 my $rv = $self->SUPER::STORE( $key, $value );
80 if ( $numeric_idx && $rv == 2 && $orig >= $size ) {
81 $self->STORESIZE( $orig + 1 );
88 my $self = $_[0]->_get_self;
91 if ( $key =~ /^-?\d+$/ ) {
93 $key += $self->FETCHSIZE;
94 return unless $key >= 0;
97 $key = pack($DBM::Deep::LONG_PACK, $key);
100 return $self->SUPER::EXISTS( $key );
105 # Return the length of the array
107 my $self = $_[0]->_get_self;
109 my $SAVE_FILTER = $self->root->{filter_fetch_value};
110 $self->root->{filter_fetch_value} = undef;
112 my $packed_size = $self->FETCH('length');
114 $self->root->{filter_fetch_value} = $SAVE_FILTER;
117 return int(unpack($DBM::Deep::LONG_PACK, $packed_size));
125 # Set the length of the array
127 my $self = $_[0]->_get_self;
128 my $new_length = $_[1];
130 my $SAVE_FILTER = $self->root->{filter_store_value};
131 $self->root->{filter_store_value} = undef;
133 my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
135 $self->root->{filter_store_value} = $SAVE_FILTER;
142 # Remove and return the last element on the array
144 my $self = $_[0]->_get_self;
145 my $length = $self->FETCHSIZE();
148 my $content = $self->FETCH( $length - 1 );
149 $self->DELETE( $length - 1 );
159 # Add new element(s) to the end of the array
161 my $self = shift->_get_self;
162 my $length = $self->FETCHSIZE();
164 while (my $content = shift @_) {
165 $self->STORE( $length, $content );
174 # Remove and return first element on the array.
175 # Shift over remaining elements to take up space.
177 my $self = $_[0]->_get_self;
178 my $length = $self->FETCHSIZE();
181 my $content = $self->FETCH( 0 );
184 # Shift elements over and remove last one.
186 for (my $i = 0; $i < $length - 1; $i++) {
187 $self->STORE( $i, $self->FETCH($i + 1) );
189 $self->DELETE( $length - 1 );
200 # Insert new element(s) at beginning of array.
201 # Shift over other elements to make space.
203 my $self = shift->_get_self;
204 my @new_elements = @_;
205 my $length = $self->FETCHSIZE();
206 my $new_size = scalar @new_elements;
209 for (my $i = $length - 1; $i >= 0; $i--) {
210 $self->STORE( $i + $new_size, $self->FETCH($i) );
214 for (my $i = 0; $i < $new_size; $i++) {
215 $self->STORE( $i, $new_elements[$i] );
218 return $length + $new_size;
223 # Splices section of array with optional new section.
224 # Returns deleted section, or last element deleted in scalar context.
226 my $self = shift->_get_self;
227 my $length = $self->FETCHSIZE();
230 # Calculate offset and length of splice
232 my $offset = shift || 0;
233 if ($offset < 0) { $offset += $length; }
236 if (scalar @_) { $splice_length = shift; }
237 else { $splice_length = $length - $offset; }
238 if ($splice_length < 0) { $splice_length += ($length - $offset); }
241 # Setup array with new elements, and copy out old elements for return
243 my @new_elements = @_;
244 my $new_size = scalar @new_elements;
246 my @old_elements = ();
247 for (my $i = $offset; $i < $offset + $splice_length; $i++) {
248 push @old_elements, $self->FETCH( $i );
252 # Adjust array length, and shift elements to accomodate new section.
254 if ( $new_size != $splice_length ) {
255 if ($new_size > $splice_length) {
256 for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
257 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
261 for (my $i = $offset + $splice_length; $i < $length; $i++) {
262 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
264 for (my $i = 0; $i < $splice_length - $new_size; $i++) {
265 $self->DELETE( $length - 1 );
272 # Insert new elements into array
274 for (my $i = $offset; $i < $offset + $new_size; $i++) {
275 $self->STORE( $i, shift @new_elements );
279 # Return deleted section, or last element in scalar context.
281 return wantarray ? @old_elements : $old_elements[-1];
284 #XXX We don't need to define it.
285 #XXX It will be useful, though, when we split out HASH and ARRAY
288 # Perl will call EXTEND() when the array is likely to grow.
289 # We don't care, but include it for compatibility.
294 # Public method aliases
296 *length = *FETCHSIZE;