lib/DBM/Deep/Array.pm

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