lib/DBM/Deep/Array.pm

   1 package DBM::Deep::Array;
   2
   3 use strict;
   4
   5 use base 'DBM::Deep';
   6
   7 sub TIEARRAY {
   8 ##
   9 # Tied array constructor method, called by Perl's tie() function.
  10 ##
  11     my $class = shift;
  12     my $args;
  13     if (scalar(@_) > 1) { $args = {@_}; }
  14     #XXX This use of ref() is bad and is a bug
  15         elsif (ref($_[0])) { $args = $_[0]; }
  16         else { $args = { file => shift }; }
  17
  18         $args->{type} = $class->TYPE_ARRAY;
  19
  20         return $class->_init($args);
  21 }
  22
  23 ##
  24 # The following methods are for arrays only
  25 ##
  26
  27 sub FETCHSIZE {
  28         ##
  29         # Return the length of the array
  30         ##
  31     my $self = DBM::Deep::_get_self($_[0]);
  32
  33         my $SAVE_FILTER = $self->root->{filter_fetch_value};
  34         $self->root->{filter_fetch_value} = undef;
  35
  36         my $packed_size = $self->FETCH('length');
  37
  38         $self->root->{filter_fetch_value} = $SAVE_FILTER;
  39
  40         if ($packed_size) { return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); }
  41         else { return 0; }
  42 }
  43
  44 sub STORESIZE {
  45         ##
  46         # Set the length of the array
  47         ##
  48     my $self = DBM::Deep::_get_self($_[0]);
  49         my $new_length = $_[1];
  50
  51         my $SAVE_FILTER = $self->root->{filter_store_value};
  52         $self->root->{filter_store_value} = undef;
  53
  54         my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
  55
  56         $self->root->{filter_store_value} = $SAVE_FILTER;
  57
  58         return $result;
  59 }
  60
  61 sub POP {
  62         ##
  63         # Remove and return the last element on the array
  64         ##
  65     my $self = DBM::Deep::_get_self($_[0]);
  66         my $length = $self->FETCHSIZE();
  67
  68         if ($length) {
  69                 my $content = $self->FETCH( $length - 1 );
  70                 $self->DELETE( $length - 1 );
  71                 return $content;
  72         }
  73         else {
  74                 return;
  75         }
  76 }
  77
  78 sub PUSH {
  79         ##
  80         # Add new element(s) to the end of the array
  81         ##
  82     my $self = DBM::Deep::_get_self(shift);
  83         my $length = $self->FETCHSIZE();
  84
  85         while (my $content = shift @_) {
  86                 $self->STORE( $length, $content );
  87                 $length++;
  88         }
  89 }
  90
  91 sub SHIFT {
  92         ##
  93         # Remove and return first element on the array.
  94         # Shift over remaining elements to take up space.
  95         ##
  96     my $self = DBM::Deep::_get_self($_[0]);
  97         my $length = $self->FETCHSIZE();
  98
  99         if ($length) {
 100                 my $content = $self->FETCH( 0 );
 101
 102                 ##
 103                 # Shift elements over and remove last one.
 104                 ##
 105                 for (my $i = 0; $i < $length - 1; $i++) {
 106                         $self->STORE( $i, $self->FETCH($i + 1) );
 107                 }
 108                 $self->DELETE( $length - 1 );
 109
 110                 return $content;
 111         }
 112         else {
 113                 return;
 114         }
 115 }
 116
 117 sub UNSHIFT {
 118         ##
 119         # Insert new element(s) at beginning of array.
 120         # Shift over other elements to make space.
 121         ##
 122     my $self = DBM::Deep::_get_self($_[0]);shift @_;
 123         my @new_elements = @_;
 124         my $length = $self->FETCHSIZE();
 125         my $new_size = scalar @new_elements;
 126
 127         if ($length) {
 128                 for (my $i = $length - 1; $i >= 0; $i--) {
 129                         $self->STORE( $i + $new_size, $self->FETCH($i) );
 130                 }
 131         }
 132
 133         for (my $i = 0; $i < $new_size; $i++) {
 134                 $self->STORE( $i, $new_elements[$i] );
 135         }
 136 }
 137
 138 sub SPLICE {
 139         ##
 140         # Splices section of array with optional new section.
 141         # Returns deleted section, or last element deleted in scalar context.
 142         ##
 143     my $self = DBM::Deep::_get_self($_[0]);shift @_;
 144         my $length = $self->FETCHSIZE();
 145
 146         ##
 147         # Calculate offset and length of splice
 148         ##
 149         my $offset = shift || 0;
 150         if ($offset < 0) { $offset += $length; }
 151
 152         my $splice_length;
 153         if (scalar @_) { $splice_length = shift; }
 154         else { $splice_length = $length - $offset; }
 155         if ($splice_length < 0) { $splice_length += ($length - $offset); }
 156
 157         ##
 158         # Setup array with new elements, and copy out old elements for return
 159         ##
 160         my @new_elements = @_;
 161         my $new_size = scalar @new_elements;
 162
 163         my @old_elements = ();
 164         for (my $i = $offset; $i < $offset + $splice_length; $i++) {
 165                 push @old_elements, $self->FETCH( $i );
 166         }
 167
 168         ##
 169         # Adjust array length, and shift elements to accomodate new section.
 170         ##
 171     if ( $new_size != $splice_length ) {
 172         if ($new_size > $splice_length) {
 173             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 174                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 175             }
 176         }
 177         else {
 178             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 179                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 180             }
 181             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 182                 $self->DELETE( $length - 1 );
 183                 $length--;
 184             }
 185         }
 186         }
 187
 188         ##
 189         # Insert new elements into array
 190         ##
 191         for (my $i = $offset; $i < $offset + $new_size; $i++) {
 192                 $self->STORE( $i, shift @new_elements );
 193         }
 194
 195         ##
 196         # Return deleted section, or last element in scalar context.
 197         ##
 198         return wantarray ? @old_elements : $old_elements[-1];
 199 }
 200
 201 #XXX We don't need to define it.
 202 #XXX It will be useful, though, when we split out HASH and ARRAY
 203 #sub EXTEND {
 204         ##
 205         # Perl will call EXTEND() when the array is likely to grow.
 206         # We don't care, but include it for compatibility.
 207         ##
 208 #}
 209
 210 ##
 211 # Public method aliases
 212 ##
 213 *length = *FETCHSIZE;
 214 *pop = *POP;
 215 *push = *PUSH;
 216 *shift = *SHIFT;
 217 *unshift = *UNSHIFT;
 218 *splice = *SPLICE;
 219
 220 1;
 221 __END__