lib/DBM/Deep/Array.pm

   1 package DBM::Deep::Array;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 # This is to allow DBM::Deep::Array to handle negative indices on
   9 # its own. Otherwise, Perl would intercept the call to negative
  10 # indices for us. This was causing bugs for negative index handling.
  11 our $NEGATIVE_INDICES = 1;
  12
  13 use base 'DBM::Deep';
  14
  15 use Scalar::Util ();
  16
  17 sub _get_self {
  18     eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
  19 }
  20
  21 sub _repr { [] }
  22
  23 sub TIEARRAY {
  24     my $class = shift;
  25     my $args = $class->_get_args( @_ );
  26
  27     $args->{type} = $class->TYPE_ARRAY;
  28
  29     return $class->_init($args);
  30 }
  31
  32 sub FETCH {
  33     my $self = shift->_get_self;
  34     my ($key) = @_;
  35
  36     $self->lock( $self->LOCK_SH );
  37
  38     if ( !defined $key ) {
  39         $self->unlock;
  40         DBM::Deep->_throw_error( "Cannot use an undefined array index." );
  41     }
  42     elsif ( $key =~ /^-?\d+$/ ) {
  43         if ( $key < 0 ) {
  44             $key += $self->FETCHSIZE;
  45             unless ( $key >= 0 ) {
  46                 $self->unlock;
  47                 return;
  48             }
  49         }
  50     }
  51     elsif ( $key ne 'length' ) {
  52         $self->unlock;
  53         DBM::Deep->_throw_error( "Cannot use '$key' as an array index." );
  54     }
  55
  56     my $rv = $self->SUPER::FETCH( $key );
  57
  58     $self->unlock;
  59
  60     return $rv;
  61 }
  62
  63 sub STORE {
  64     my $self = shift->_get_self;
  65     my ($key, $value) = @_;
  66
  67     $self->lock( $self->LOCK_EX );
  68
  69     my $size;
  70     my $idx_is_numeric;
  71     if ( !defined $key ) {
  72         $self->unlock;
  73         DBM::Deep->_throw_error( "Cannot use an undefined array index." );
  74     }
  75     elsif ( $key =~ /^-?\d+$/ ) {
  76         $idx_is_numeric = 1;
  77         if ( $key < 0 ) {
  78             $size = $self->FETCHSIZE;
  79             if ( $key + $size < 0 ) {
  80                 die( "Modification of non-creatable array value attempted, subscript $key" );
  81             }
  82             $key += $size
  83         }
  84     }
  85     elsif ( $key ne 'length' ) {
  86         $self->unlock;
  87         DBM::Deep->_throw_error( "Cannot use '$key' as an array index." );
  88     }
  89
  90     my $rv = $self->SUPER::STORE( $key, $value );
  91
  92     if ( $idx_is_numeric ) {
  93         $size = $self->FETCHSIZE unless defined $size;
  94         if ( $key >= $size ) {
  95             $self->STORESIZE( $key + 1 );
  96         }
  97     }
  98
  99     $self->unlock;
 100
 101     return $rv;
 102 }
 103
 104 sub EXISTS {
 105     my $self = shift->_get_self;
 106     my ($key) = @_;
 107
 108     $self->lock( $self->LOCK_SH );
 109
 110     if ( !defined $key ) {
 111         $self->unlock;
 112         DBM::Deep->_throw_error( "Cannot use an undefined array index." );
 113     }
 114     elsif ( $key =~ /^-?\d+$/ ) {
 115         if ( $key < 0 ) {
 116             $key += $self->FETCHSIZE;
 117             unless ( $key >= 0 ) {
 118                 $self->unlock;
 119                 return;
 120             }
 121         }
 122     }
 123     elsif ( $key ne 'length' ) {
 124         $self->unlock;
 125         DBM::Deep->_throw_error( "Cannot use '$key' as an array index." );
 126     }
 127
 128     my $rv = $self->SUPER::EXISTS( $key );
 129
 130     $self->unlock;
 131
 132     return $rv;
 133 }
 134
 135 sub DELETE {
 136     my $self = shift->_get_self;
 137     my ($key) = @_;
 138     warn "ARRAY::DELETE($self,$key)\n" if DBM::Deep::DEBUG;
 139
 140     $self->lock( $self->LOCK_EX );
 141
 142     my $size = $self->FETCHSIZE;
 143     if ( !defined $key ) {
 144         $self->unlock;
 145         DBM::Deep->_throw_error( "Cannot use an undefined array index." );
 146     }
 147     elsif ( $key =~ /^-?\d+$/ ) {
 148         if ( $key < 0 ) {
 149             $key += $size;
 150             unless ( $key >= 0 ) {
 151                 $self->unlock;
 152                 return;
 153             }
 154         }
 155     }
 156     elsif ( $key ne 'length' ) {
 157         $self->unlock;
 158         DBM::Deep->_throw_error( "Cannot use '$key' as an array index." );
 159     }
 160
 161     my $rv = $self->SUPER::DELETE( $key );
 162
 163     if ($rv && $key == $size - 1) {
 164         $self->STORESIZE( $key );
 165     }
 166
 167     $self->unlock;
 168
 169     return $rv;
 170 }
 171
 172 # Now that we have a real Reference sector, we should store arrayzize there. However,
 173 # arraysize needs to be transactionally-aware, so a simple location to store it isn't
 174 # going to work.
 175 sub FETCHSIZE {
 176     my $self = shift->_get_self;
 177
 178     $self->lock( $self->LOCK_SH );
 179
 180     my $SAVE_FILTER = $self->_storage->{filter_fetch_value};
 181     $self->_storage->{filter_fetch_value} = undef;
 182
 183     my $size = $self->FETCH('length') || 0;
 184
 185     $self->_storage->{filter_fetch_value} = $SAVE_FILTER;
 186
 187     $self->unlock;
 188
 189     return $size;
 190 }
 191
 192 sub STORESIZE {
 193     my $self = shift->_get_self;
 194     my ($new_length) = @_;
 195
 196     $self->lock( $self->LOCK_EX );
 197
 198     my $SAVE_FILTER = $self->_storage->{filter_store_value};
 199     $self->_storage->{filter_store_value} = undef;
 200
 201     my $result = $self->STORE('length', $new_length, 'length');
 202
 203     $self->_storage->{filter_store_value} = $SAVE_FILTER;
 204
 205     $self->unlock;
 206
 207     return $result;
 208 }
 209
 210 sub POP {
 211     my $self = shift->_get_self;
 212
 213     $self->lock( $self->LOCK_EX );
 214
 215     my $length = $self->FETCHSIZE();
 216
 217     if ($length) {
 218         my $content = $self->FETCH( $length - 1 );
 219         $self->DELETE( $length - 1 );
 220
 221         $self->unlock;
 222
 223         return $content;
 224     }
 225     else {
 226         $self->unlock;
 227         return;
 228     }
 229 }
 230
 231 sub PUSH {
 232     my $self = shift->_get_self;
 233
 234     $self->lock( $self->LOCK_EX );
 235
 236     my $length = $self->FETCHSIZE();
 237
 238     while (my $content = shift @_) {
 239         $self->STORE( $length, $content );
 240         $length++;
 241     }
 242
 243     $self->unlock;
 244
 245     return $length;
 246 }
 247
 248 # XXX This really needs to be something more direct within the file, not a
 249 # fetch and re-store. -RobK, 2007-09-20
 250 sub _move_value {
 251     my $self = shift;
 252     my ($old_key, $new_key) = @_;
 253
 254     return $self->_engine->make_reference( $self, $old_key, $new_key );
 255 }
 256
 257 sub SHIFT {
 258     my $self = shift->_get_self;
 259     warn "SHIFT($self)\n" if DBM::Deep::DEBUG;
 260
 261     $self->lock( $self->LOCK_EX );
 262
 263     my $length = $self->FETCHSIZE();
 264
 265     if ( !$length ) {
 266         $self->unlock;
 267         return;
 268     }
 269
 270     my $content = $self->DELETE( 0 );
 271
 272     # Unless the deletion above has cleared the array ...
 273     if ( $length > 1 ) {
 274         for (my $i = 0; $i < $length - 1; $i++) {
 275             $self->_move_value( $i+1, $i );
 276         }
 277
 278         $self->DELETE( $length - 1 );
 279     }
 280
 281     $self->unlock;
 282
 283     return $content;
 284 }
 285
 286 sub UNSHIFT {
 287     my $self = shift->_get_self;
 288     my @new_elements = @_;
 289
 290     $self->lock( $self->LOCK_EX );
 291
 292     my $length = $self->FETCHSIZE();
 293     my $new_size = scalar @new_elements;
 294
 295     if ($length) {
 296         for (my $i = $length - 1; $i >= 0; $i--) {
 297             $self->_move_value( $i, $i+$new_size );
 298         }
 299
 300         $self->STORESIZE( $length + $new_size );
 301     }
 302
 303     for (my $i = 0; $i < $new_size; $i++) {
 304         $self->STORE( $i, $new_elements[$i] );
 305     }
 306
 307     $self->unlock;
 308
 309     return $length + $new_size;
 310 }
 311
 312 sub SPLICE {
 313     my $self = shift->_get_self;
 314
 315     $self->lock( $self->LOCK_EX );
 316
 317     my $length = $self->FETCHSIZE();
 318
 319     ##
 320     # Calculate offset and length of splice
 321     ##
 322     my $offset = shift;
 323     $offset = 0 unless defined $offset;
 324     if ($offset < 0) { $offset += $length; }
 325
 326     my $splice_length;
 327     if (scalar @_) { $splice_length = shift; }
 328     else { $splice_length = $length - $offset; }
 329     if ($splice_length < 0) { $splice_length += ($length - $offset); }
 330
 331     ##
 332     # Setup array with new elements, and copy out old elements for return
 333     ##
 334     my @new_elements = @_;
 335     my $new_size = scalar @new_elements;
 336
 337     my @old_elements = map {
 338         $self->FETCH( $_ )
 339     } $offset .. ($offset + $splice_length - 1);
 340
 341     ##
 342     # Adjust array length, and shift elements to accomodate new section.
 343     ##
 344     if ( $new_size != $splice_length ) {
 345         if ($new_size > $splice_length) {
 346             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 347                 $self->_move_value( $i, $i + ($new_size - $splice_length) );
 348             }
 349             $self->STORESIZE( $length + $new_size - $splice_length );
 350         }
 351         else {
 352             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 353                 $self->_move_value( $i, $i + ($new_size - $splice_length) );
 354             }
 355             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 356                 $self->DELETE( $length - 1 );
 357                 $length--;
 358             }
 359         }
 360     }
 361
 362     ##
 363     # Insert new elements into array
 364     ##
 365     for (my $i = $offset; $i < $offset + $new_size; $i++) {
 366         $self->STORE( $i, shift @new_elements );
 367     }
 368
 369     $self->unlock;
 370
 371     ##
 372     # Return deleted section, or last element in scalar context.
 373     ##
 374     return wantarray ? @old_elements : $old_elements[-1];
 375 }
 376
 377 # We don't need to populate it, yet.
 378 # It will be useful, though, when we split out HASH and ARRAY
 379 sub EXTEND {
 380     ##
 381     # Perl will call EXTEND() when the array is likely to grow.
 382     # We don't care, but include it because it gets called at times.
 383     ##
 384 }
 385
 386 sub _copy_node {
 387     my $self = shift;
 388     my ($db_temp) = @_;
 389
 390     my $length = $self->length();
 391     for (my $index = 0; $index < $length; $index++) {
 392         $self->_copy_value( \$db_temp->[$index], $self->get($index) );
 393     }
 394
 395     return 1;
 396 }
 397
 398 ##
 399 # Public method aliases
 400 ##
 401 sub length { (shift)->FETCHSIZE(@_) }
 402 sub pop { (shift)->POP(@_) }
 403 sub push { (shift)->PUSH(@_) }
 404 sub unshift { (shift)->UNSHIFT(@_) }
 405 sub splice { (shift)->SPLICE(@_) }
 406
 407 # This must be last otherwise we have to qualify all other calls to shift
 408 # as calls to CORE::shift
 409 sub shift { (CORE::shift)->SHIFT(@_) }
 410
 411 1;
 412 __END__