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
  95 sub SHIFT {
  96         ##
  97         # Remove and return first element on the array.
  98         # Shift over remaining elements to take up space.
  99         ##
 100     my $self = $_[0]->_get_self;
 101         my $length = $self->FETCHSIZE();
 102
 103         if ($length) {
 104                 my $content = $self->FETCH( 0 );
 105
 106                 ##
 107                 # Shift elements over and remove last one.
 108                 ##
 109                 for (my $i = 0; $i < $length - 1; $i++) {
 110                         $self->STORE( $i, $self->FETCH($i + 1) );
 111                 }
 112                 $self->DELETE( $length - 1 );
 113
 114                 return $content;
 115         }
 116         else {
 117                 return;
 118         }
 119 }
 120
 121 sub UNSHIFT {
 122         ##
 123         # Insert new element(s) at beginning of array.
 124         # Shift over other elements to make space.
 125         ##
 126     my $self = shift->_get_self;
 127         my @new_elements = @_;
 128         my $length = $self->FETCHSIZE();
 129         my $new_size = scalar @new_elements;
 130
 131         if ($length) {
 132                 for (my $i = $length - 1; $i >= 0; $i--) {
 133                         $self->STORE( $i + $new_size, $self->FETCH($i) );
 134                 }
 135         }
 136
 137         for (my $i = 0; $i < $new_size; $i++) {
 138                 $self->STORE( $i, $new_elements[$i] );
 139         }
 140 }
 141
 142 sub SPLICE {
 143         ##
 144         # Splices section of array with optional new section.
 145         # Returns deleted section, or last element deleted in scalar context.
 146         ##
 147     my $self = shift->_get_self;
 148         my $length = $self->FETCHSIZE();
 149
 150         ##
 151         # Calculate offset and length of splice
 152         ##
 153         my $offset = shift || 0;
 154         if ($offset < 0) { $offset += $length; }
 155
 156         my $splice_length;
 157         if (scalar @_) { $splice_length = shift; }
 158         else { $splice_length = $length - $offset; }
 159         if ($splice_length < 0) { $splice_length += ($length - $offset); }
 160
 161         ##
 162         # Setup array with new elements, and copy out old elements for return
 163         ##
 164         my @new_elements = @_;
 165         my $new_size = scalar @new_elements;
 166
 167         my @old_elements = ();
 168         for (my $i = $offset; $i < $offset + $splice_length; $i++) {
 169                 push @old_elements, $self->FETCH( $i );
 170         }
 171
 172         ##
 173         # Adjust array length, and shift elements to accomodate new section.
 174         ##
 175     if ( $new_size != $splice_length ) {
 176         if ($new_size > $splice_length) {
 177             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 178                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 179             }
 180         }
 181         else {
 182             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 183                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 184             }
 185             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 186                 $self->DELETE( $length - 1 );
 187                 $length--;
 188             }
 189         }
 190         }
 191
 192         ##
 193         # Insert new elements into array
 194         ##
 195         for (my $i = $offset; $i < $offset + $new_size; $i++) {
 196                 $self->STORE( $i, shift @new_elements );
 197         }
 198
 199         ##
 200         # Return deleted section, or last element in scalar context.
 201         ##
 202         return wantarray ? @old_elements : $old_elements[-1];
 203 }
 204
 205 #XXX We don't need to define it.
 206 #XXX It will be useful, though, when we split out HASH and ARRAY
 207 #sub EXTEND {
 208         ##
 209         # Perl will call EXTEND() when the array is likely to grow.
 210         # We don't care, but include it for compatibility.
 211         ##
 212 #}
 213
 214 ##
 215 # Public method aliases
 216 ##
 217 *length = *FETCHSIZE;
 218 *pop = *POP;
 219 *push = *PUSH;
 220 *shift = *SHIFT;
 221 *unshift = *UNSHIFT;
 222 *splice = *SPLICE;
 223
 224 1;
 225 __END__