lib/DBM/Deep/Array.pm

   1 package DBM::Deep::Array;
   2
   3 use strict;
   4
   5 # This is to allow DBM::Deep::Array to handle negative indices on
   6 # its own. Otherwise, Perl would intercept the call to negative
   7 # indices for us. This was causing bugs for negative index handling.
   8 use vars qw( $NEGATIVE_INDICES );
   9 $NEGATIVE_INDICES = 1;
  10
  11 use base 'DBM::Deep';
  12
  13 use Scalar::Util ();
  14
  15 sub _get_self {
  16     eval { tied( @{$_[0]} ) } || $_[0]
  17 }
  18
  19 sub TIEARRAY {
  20 ##
  21 # Tied array constructor method, called by Perl's tie() function.
  22 ##
  23     my $class = shift;
  24     my $args = $class->_get_args( @_ );
  25
  26         $args->{type} = $class->TYPE_ARRAY;
  27
  28         return $class->_init($args);
  29 }
  30
  31 sub FETCH {
  32     my $self = $_[0]->_get_self;
  33     my $key = $_[1];
  34
  35         $self->lock( $self->LOCK_SH );
  36
  37     if ( $key =~ /^-?\d+$/ ) {
  38         if ( $key < 0 ) {
  39             $key += $self->FETCHSIZE;
  40             unless ( $key >= 0 ) {
  41                 $self->unlock;
  42                 return;
  43             }
  44         }
  45
  46         $key = pack($DBM::Deep::LONG_PACK, $key);
  47     }
  48
  49     my $rv = $self->SUPER::FETCH( $key );
  50
  51     $self->unlock;
  52
  53     return $rv;
  54 }
  55
  56 sub STORE {
  57     my $self = shift->_get_self;
  58     my ($key, $value) = @_;
  59
  60     $self->lock( $self->LOCK_EX );
  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     $self->unlock;
  85
  86     return $rv;
  87 }
  88
  89 sub EXISTS {
  90     my $self = $_[0]->_get_self;
  91     my $key = $_[1];
  92
  93         $self->lock( $self->LOCK_SH );
  94
  95     if ( $key =~ /^-?\d+$/ ) {
  96         if ( $key < 0 ) {
  97             $key += $self->FETCHSIZE;
  98             unless ( $key >= 0 ) {
  99                 $self->unlock;
 100                 return;
 101             }
 102         }
 103
 104         $key = pack($DBM::Deep::LONG_PACK, $key);
 105     }
 106
 107     my $rv = $self->SUPER::EXISTS( $key );
 108
 109     $self->unlock;
 110
 111     return $rv;
 112 }
 113
 114 sub DELETE {
 115     my $self = $_[0]->_get_self;
 116     my $key = $_[1];
 117
 118     my $unpacked_key = $key;
 119
 120     $self->lock( $self->LOCK_EX );
 121
 122     my $size = $self->FETCHSIZE;
 123     if ( $key =~ /^-?\d+$/ ) {
 124         if ( $key < 0 ) {
 125             $key += $size;
 126             unless ( $key >= 0 ) {
 127                 $self->unlock;
 128                 return;
 129             }
 130         }
 131
 132         $key = pack($DBM::Deep::LONG_PACK, $key);
 133     }
 134
 135     my $rv = $self->SUPER::DELETE( $key );
 136
 137         if ($rv && $unpacked_key == $size - 1) {
 138                 $self->STORESIZE( $unpacked_key );
 139         }
 140
 141     $self->unlock;
 142
 143     return $rv;
 144 }
 145
 146 sub FETCHSIZE {
 147         ##
 148         # Return the length of the array
 149         ##
 150     my $self = shift->_get_self;
 151
 152     $self->lock( $self->LOCK_SH );
 153
 154         my $SAVE_FILTER = $self->root->{filter_fetch_value};
 155         $self->root->{filter_fetch_value} = undef;
 156
 157         my $packed_size = $self->FETCH('length');
 158
 159         $self->root->{filter_fetch_value} = $SAVE_FILTER;
 160
 161     $self->unlock;
 162
 163         if ($packed_size) {
 164         return int(unpack($DBM::Deep::LONG_PACK, $packed_size));
 165     }
 166
 167         return 0;
 168 }
 169
 170 sub STORESIZE {
 171         ##
 172         # Set the length of the array
 173         ##
 174     my $self = $_[0]->_get_self;
 175         my $new_length = $_[1];
 176
 177     $self->lock( $self->LOCK_EX );
 178
 179         my $SAVE_FILTER = $self->root->{filter_store_value};
 180         $self->root->{filter_store_value} = undef;
 181
 182         my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length));
 183
 184         $self->root->{filter_store_value} = $SAVE_FILTER;
 185
 186     $self->unlock;
 187
 188         return $result;
 189 }
 190
 191 sub POP {
 192         ##
 193         # Remove and return the last element on the array
 194         ##
 195     my $self = $_[0]->_get_self;
 196
 197     $self->lock( $self->LOCK_EX );
 198
 199         my $length = $self->FETCHSIZE();
 200
 201         if ($length) {
 202                 my $content = $self->FETCH( $length - 1 );
 203                 $self->DELETE( $length - 1 );
 204
 205         $self->unlock;
 206
 207                 return $content;
 208         }
 209         else {
 210         $self->unlock;
 211                 return;
 212         }
 213 }
 214
 215 sub PUSH {
 216         ##
 217         # Add new element(s) to the end of the array
 218         ##
 219     my $self = shift->_get_self;
 220
 221     $self->lock( $self->LOCK_EX );
 222
 223         my $length = $self->FETCHSIZE();
 224
 225         while (my $content = shift @_) {
 226                 $self->STORE( $length, $content );
 227                 $length++;
 228         }
 229
 230     $self->unlock;
 231
 232     return $length;
 233 }
 234
 235 sub SHIFT {
 236         ##
 237         # Remove and return first element on the array.
 238         # Shift over remaining elements to take up space.
 239         ##
 240     my $self = $_[0]->_get_self;
 241
 242     $self->lock( $self->LOCK_EX );
 243
 244         my $length = $self->FETCHSIZE();
 245
 246         if ($length) {
 247                 my $content = $self->FETCH( 0 );
 248
 249                 ##
 250                 # Shift elements over and remove last one.
 251                 ##
 252                 for (my $i = 0; $i < $length - 1; $i++) {
 253                         $self->STORE( $i, $self->FETCH($i + 1) );
 254                 }
 255                 $self->DELETE( $length - 1 );
 256
 257         $self->unlock;
 258
 259                 return $content;
 260         }
 261         else {
 262         $self->unlock;
 263                 return;
 264         }
 265 }
 266
 267 sub UNSHIFT {
 268         ##
 269         # Insert new element(s) at beginning of array.
 270         # Shift over other elements to make space.
 271         ##
 272     my $self = shift->_get_self;
 273         my @new_elements = @_;
 274
 275     $self->lock( $self->LOCK_EX );
 276
 277         my $length = $self->FETCHSIZE();
 278         my $new_size = scalar @new_elements;
 279
 280         if ($length) {
 281                 for (my $i = $length - 1; $i >= 0; $i--) {
 282                         $self->STORE( $i + $new_size, $self->FETCH($i) );
 283                 }
 284         }
 285
 286         for (my $i = 0; $i < $new_size; $i++) {
 287                 $self->STORE( $i, $new_elements[$i] );
 288         }
 289
 290     $self->unlock;
 291
 292     return $length + $new_size;
 293 }
 294
 295 sub SPLICE {
 296         ##
 297         # Splices section of array with optional new section.
 298         # Returns deleted section, or last element deleted in scalar context.
 299         ##
 300     my $self = shift->_get_self;
 301
 302     $self->lock( $self->LOCK_EX );
 303
 304         my $length = $self->FETCHSIZE();
 305
 306         ##
 307         # Calculate offset and length of splice
 308         ##
 309         my $offset = shift || 0;
 310         if ($offset < 0) { $offset += $length; }
 311
 312         my $splice_length;
 313         if (scalar @_) { $splice_length = shift; }
 314         else { $splice_length = $length - $offset; }
 315         if ($splice_length < 0) { $splice_length += ($length - $offset); }
 316
 317         ##
 318         # Setup array with new elements, and copy out old elements for return
 319         ##
 320         my @new_elements = @_;
 321         my $new_size = scalar @new_elements;
 322
 323         my @old_elements = ();
 324         for (my $i = $offset; $i < $offset + $splice_length; $i++) {
 325                 push @old_elements, $self->FETCH( $i );
 326         }
 327
 328         ##
 329         # Adjust array length, and shift elements to accomodate new section.
 330         ##
 331     if ( $new_size != $splice_length ) {
 332         if ($new_size > $splice_length) {
 333             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 334                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 335             }
 336         }
 337         else {
 338             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 339                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 340             }
 341             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 342                 $self->DELETE( $length - 1 );
 343                 $length--;
 344             }
 345         }
 346         }
 347
 348         ##
 349         # Insert new elements into array
 350         ##
 351         for (my $i = $offset; $i < $offset + $new_size; $i++) {
 352                 $self->STORE( $i, shift @new_elements );
 353         }
 354
 355     $self->unlock;
 356
 357         ##
 358         # Return deleted section, or last element in scalar context.
 359         ##
 360         return wantarray ? @old_elements : $old_elements[-1];
 361 }
 362
 363 #XXX We don't need to define it, yet.
 364 #XXX It will be useful, though, when we split out HASH and ARRAY
 365 #sub EXTEND {
 366         ##
 367         # Perl will call EXTEND() when the array is likely to grow.
 368         # We don't care, but include it for compatibility.
 369         ##
 370 #}
 371
 372 ##
 373 # Public method aliases
 374 ##
 375 *length = *FETCHSIZE;
 376 *pop = *POP;
 377 *push = *PUSH;
 378 *shift = *SHIFT;
 379 *unshift = *UNSHIFT;
 380 *splice = *SPLICE;
 381
 382 1;
 383 __END__