1 package DBM::Deep::Array;
10 eval { tied( @{$_[0]} ) } || $_[0]
15 # Tied array constructor method, called by Perl's tie() function.
21 $class->_throw_error( "Odd number of parameters to TIEARRAY" );
25 elsif ( my $type = Scalar::Util::reftype($_[0]) ) {
26 if ( $type ne 'HASH' ) {
27 $class->_throw_error( "Not a hashref in TIEARRAY" );
32 $args = { file => shift };
35 $args->{type} = $class->TYPE_ARRAY;
37 return $class->_init($args);
41 # The following methods are for arrays only
46 # Return the length of the array
48 my $self = $_[0]->_get_self;
50 my $SAVE_FILTER = $self->root->{filter_fetch_value};
51 $self->root->{filter_fetch_value} = undef;
53 my $packed_size = $self->FETCH('length');
55 $self->root->{filter_fetch_value} = $SAVE_FILTER;
57 if ($packed_size) { return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); }
63 # Set the length of the array
65 my $self = $_[0]->_get_self;
66 my $new_length = $_[1];
68 my $SAVE_FILTER = $self->root->{filter_store_value};
69 $self->root->{filter_store_value} = undef;
71 my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
73 $self->root->{filter_store_value} = $SAVE_FILTER;
80 # Remove and return the last element on the array
82 my $self = $_[0]->_get_self;
83 my $length = $self->FETCHSIZE();
86 my $content = $self->FETCH( $length - 1 );
87 $self->DELETE( $length - 1 );
97 # Add new element(s) to the end of the array
99 my $self = shift->_get_self;
100 my $length = $self->FETCHSIZE();
102 while (my $content = shift @_) {
103 $self->STORE( $length, $content );
112 # Remove and return first element on the array.
113 # Shift over remaining elements to take up space.
115 my $self = $_[0]->_get_self;
116 my $length = $self->FETCHSIZE();
119 my $content = $self->FETCH( 0 );
122 # Shift elements over and remove last one.
124 for (my $i = 0; $i < $length - 1; $i++) {
125 $self->STORE( $i, $self->FETCH($i + 1) );
127 $self->DELETE( $length - 1 );
138 # Insert new element(s) at beginning of array.
139 # Shift over other elements to make space.
141 my $self = shift->_get_self;
142 my @new_elements = @_;
143 my $length = $self->FETCHSIZE();
144 my $new_size = scalar @new_elements;
147 for (my $i = $length - 1; $i >= 0; $i--) {
148 $self->STORE( $i + $new_size, $self->FETCH($i) );
152 for (my $i = 0; $i < $new_size; $i++) {
153 $self->STORE( $i, $new_elements[$i] );
156 return $length + $new_size;
161 # Splices section of array with optional new section.
162 # Returns deleted section, or last element deleted in scalar context.
164 my $self = shift->_get_self;
165 my $length = $self->FETCHSIZE();
168 # Calculate offset and length of splice
170 my $offset = shift || 0;
171 if ($offset < 0) { $offset += $length; }
174 if (scalar @_) { $splice_length = shift; }
175 else { $splice_length = $length - $offset; }
176 if ($splice_length < 0) { $splice_length += ($length - $offset); }
179 # Setup array with new elements, and copy out old elements for return
181 my @new_elements = @_;
182 my $new_size = scalar @new_elements;
184 my @old_elements = ();
185 for (my $i = $offset; $i < $offset + $splice_length; $i++) {
186 push @old_elements, $self->FETCH( $i );
190 # Adjust array length, and shift elements to accomodate new section.
192 if ( $new_size != $splice_length ) {
193 if ($new_size > $splice_length) {
194 for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
195 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
199 for (my $i = $offset + $splice_length; $i < $length; $i++) {
200 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
202 for (my $i = 0; $i < $splice_length - $new_size; $i++) {
203 $self->DELETE( $length - 1 );
210 # Insert new elements into array
212 for (my $i = $offset; $i < $offset + $new_size; $i++) {
213 $self->STORE( $i, shift @new_elements );
217 # Return deleted section, or last element in scalar context.
219 return wantarray ? @old_elements : $old_elements[-1];
222 #XXX We don't need to define it.
223 #XXX It will be useful, though, when we split out HASH and ARRAY
226 # Perl will call EXTEND() when the array is likely to grow.
227 # We don't care, but include it for compatibility.
232 # Public method aliases
234 *length = *FETCHSIZE;