lib/DBM/Deep/Array.pm

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