1 package DBM::Deep::Array;
8 eval { tied( @{$_[0]} ) } || $_[0]
13 # Tied array constructor method, called by Perl's tie() function.
17 if (scalar(@_) > 1) { $args = {@_}; }
18 #XXX This use of ref() is bad and is a bug
19 elsif (ref($_[0])) { $args = $_[0]; }
20 else { $args = { file => shift }; }
22 $args->{type} = $class->TYPE_ARRAY;
24 return $class->_init($args);
28 # The following methods are for arrays only
33 # Return the length of the array
35 my $self = $_[0]->_get_self;
37 my $SAVE_FILTER = $self->root->{filter_fetch_value};
38 $self->root->{filter_fetch_value} = undef;
40 my $packed_size = $self->FETCH('length');
42 $self->root->{filter_fetch_value} = $SAVE_FILTER;
44 if ($packed_size) { return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); }
50 # Set the length of the array
52 my $self = $_[0]->_get_self;
53 my $new_length = $_[1];
55 my $SAVE_FILTER = $self->root->{filter_store_value};
56 $self->root->{filter_store_value} = undef;
58 my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
60 $self->root->{filter_store_value} = $SAVE_FILTER;
67 # Remove and return the last element on the array
69 my $self = $_[0]->_get_self;
70 my $length = $self->FETCHSIZE();
73 my $content = $self->FETCH( $length - 1 );
74 $self->DELETE( $length - 1 );
84 # Add new element(s) to the end of the array
86 my $self = shift->_get_self;
87 my $length = $self->FETCHSIZE();
89 while (my $content = shift @_) {
90 $self->STORE( $length, $content );
97 # Remove and return first element on the array.
98 # Shift over remaining elements to take up space.
100 my $self = $_[0]->_get_self;
101 my $length = $self->FETCHSIZE();
104 my $content = $self->FETCH( 0 );
107 # Shift elements over and remove last one.
109 for (my $i = 0; $i < $length - 1; $i++) {
110 $self->STORE( $i, $self->FETCH($i + 1) );
112 $self->DELETE( $length - 1 );
123 # Insert new element(s) at beginning of array.
124 # Shift over other elements to make space.
126 my $self = shift->_get_self;
127 my @new_elements = @_;
128 my $length = $self->FETCHSIZE();
129 my $new_size = scalar @new_elements;
132 for (my $i = $length - 1; $i >= 0; $i--) {
133 $self->STORE( $i + $new_size, $self->FETCH($i) );
137 for (my $i = 0; $i < $new_size; $i++) {
138 $self->STORE( $i, $new_elements[$i] );
144 # Splices section of array with optional new section.
145 # Returns deleted section, or last element deleted in scalar context.
147 my $self = shift->_get_self;
148 my $length = $self->FETCHSIZE();
151 # Calculate offset and length of splice
153 my $offset = shift || 0;
154 if ($offset < 0) { $offset += $length; }
157 if (scalar @_) { $splice_length = shift; }
158 else { $splice_length = $length - $offset; }
159 if ($splice_length < 0) { $splice_length += ($length - $offset); }
162 # Setup array with new elements, and copy out old elements for return
164 my @new_elements = @_;
165 my $new_size = scalar @new_elements;
167 my @old_elements = ();
168 for (my $i = $offset; $i < $offset + $splice_length; $i++) {
169 push @old_elements, $self->FETCH( $i );
173 # Adjust array length, and shift elements to accomodate new section.
175 if ( $new_size != $splice_length ) {
176 if ($new_size > $splice_length) {
177 for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
178 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
182 for (my $i = $offset + $splice_length; $i < $length; $i++) {
183 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
185 for (my $i = 0; $i < $splice_length - $new_size; $i++) {
186 $self->DELETE( $length - 1 );
193 # Insert new elements into array
195 for (my $i = $offset; $i < $offset + $new_size; $i++) {
196 $self->STORE( $i, shift @new_elements );
200 # Return deleted section, or last element in scalar context.
202 return wantarray ? @old_elements : $old_elements[-1];
205 #XXX We don't need to define it.
206 #XXX It will be useful, though, when we split out HASH and ARRAY
209 # Perl will call EXTEND() when the array is likely to grow.
210 # We don't care, but include it for compatibility.
215 # Public method aliases
217 *length = *FETCHSIZE;