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