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