lib/DBM/Deep/Array.pm

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