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