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