lib/DBM/Deep/Array.pm

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