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     my $size = $self->FETCH('length') || 0;
 193
 194     $self->_engine->storage->{filter_fetch_value} = $SAVE_FILTER;
 195
 196     $self->unlock;
 197
 198     return $size;
 199 }
 200
 201 sub STORESIZE {
 202     my $self = shift->_get_self;
 203     my ($new_length) = @_;
 204     warn "ARRAY::STORESIZE($self, $new_length)\n" if DBM::Deep::DEBUG;
 205
 206     $self->lock_exclusive;
 207
 208     my $SAVE_FILTER = $self->_engine->storage->{filter_store_value};
 209     $self->_engine->storage->{filter_store_value} = undef;
 210
 211     my $result = $self->STORE('length', $new_length, 'length');
 212
 213     $self->_engine->storage->{filter_store_value} = $SAVE_FILTER;
 214
 215     $self->unlock;
 216
 217     return $result;
 218 }
 219
 220 sub POP {
 221     my $self = shift->_get_self;
 222     warn "ARRAY::POP($self)\n" if DBM::Deep::DEBUG;
 223
 224     $self->lock_exclusive;
 225
 226     my $length = $self->FETCHSIZE();
 227
 228     if ($length) {
 229         my $content = $self->FETCH( $length - 1 );
 230         $self->DELETE( $length - 1 );
 231
 232         $self->unlock;
 233
 234         return $content;
 235     }
 236     else {
 237         $self->unlock;
 238         return;
 239     }
 240 }
 241
 242 sub PUSH {
 243     my $self = shift->_get_self;
 244     warn "ARRAY::PUSH($self)\n" if DBM::Deep::DEBUG;
 245
 246     $self->lock_exclusive;
 247
 248     my $length = $self->FETCHSIZE();
 249
 250     while (my $content = shift @_) {
 251         $self->STORE( $length, $content );
 252         $length++;
 253     }
 254
 255     $self->unlock;
 256
 257     return $length;
 258 }
 259
 260 # XXX This really needs to be something more direct within the file, not a
 261 # fetch and re-store. -RobK, 2007-09-20
 262 sub _move_value {
 263     my $self = shift;
 264     my ($old_key, $new_key) = @_;
 265
 266     return $self->_engine->make_reference( $self, $old_key, $new_key );
 267 }
 268
 269 sub SHIFT {
 270     my $self = shift->_get_self;
 271     warn "ARRAY::SHIFT($self)\n" if DBM::Deep::DEBUG;
 272
 273     $self->lock_exclusive;
 274
 275     my $length = $self->FETCHSIZE();
 276
 277     if ( !$length ) {
 278         $self->unlock;
 279         return;
 280     }
 281
 282     my $content = $self->DELETE( 0 );
 283
 284     # Unless the deletion above has cleared the array ...
 285     if ( $length > 1 ) {
 286         for (my $i = 0; $i < $length - 1; $i++) {
 287             $self->_move_value( $i+1, $i );
 288         }
 289
 290         $self->DELETE( $length - 1 );
 291     }
 292
 293     $self->unlock;
 294
 295     return $content;
 296 }
 297
 298 sub UNSHIFT {
 299     my $self = shift->_get_self;
 300     warn "ARRAY::UNSHIFT($self)\n" if DBM::Deep::DEBUG;
 301     my @new_elements = @_;
 302
 303     $self->lock_exclusive;
 304
 305     my $length = $self->FETCHSIZE();
 306     my $new_size = scalar @new_elements;
 307
 308     if ($length) {
 309         for (my $i = $length - 1; $i >= 0; $i--) {
 310             $self->_move_value( $i, $i+$new_size );
 311         }
 312
 313         $self->STORESIZE( $length + $new_size );
 314     }
 315
 316     for (my $i = 0; $i < $new_size; $i++) {
 317         $self->STORE( $i, $new_elements[$i] );
 318     }
 319
 320     $self->unlock;
 321
 322     return $length + $new_size;
 323 }
 324
 325 sub SPLICE {
 326     my $self = shift->_get_self;
 327     warn "ARRAY::SPLICE($self)\n" if DBM::Deep::DEBUG;
 328
 329     $self->lock_exclusive;
 330
 331     my $length = $self->FETCHSIZE();
 332
 333     ##
 334     # Calculate offset and length of splice
 335     ##
 336     my $offset = shift;
 337     $offset = 0 unless defined $offset;
 338     if ($offset < 0) { $offset += $length; }
 339
 340     my $splice_length;
 341     if (scalar @_) { $splice_length = shift; }
 342     else { $splice_length = $length - $offset; }
 343     if ($splice_length < 0) { $splice_length += ($length - $offset); }
 344
 345     ##
 346     # Setup array with new elements, and copy out old elements for return
 347     ##
 348     my @new_elements = @_;
 349     my $new_size = scalar @new_elements;
 350
 351     my @old_elements = map {
 352         $self->FETCH( $_ )
 353     } $offset .. ($offset + $splice_length - 1);
 354
 355     ##
 356     # Adjust array length, and shift elements to accomodate new section.
 357     ##
 358     if ( $new_size != $splice_length ) {
 359         if ($new_size > $splice_length) {
 360             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 361                 $self->_move_value( $i, $i + ($new_size - $splice_length) );
 362             }
 363             $self->STORESIZE( $length + $new_size - $splice_length );
 364         }
 365         else {
 366             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 367                 $self->_move_value( $i, $i + ($new_size - $splice_length) );
 368             }
 369             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 370                 $self->DELETE( $length - 1 );
 371                 $length--;
 372             }
 373         }
 374     }
 375
 376     ##
 377     # Insert new elements into array
 378     ##
 379     for (my $i = $offset; $i < $offset + $new_size; $i++) {
 380         $self->STORE( $i, shift @new_elements );
 381     }
 382
 383     $self->unlock;
 384
 385     ##
 386     # Return deleted section, or last element in scalar context.
 387     ##
 388     return wantarray ? @old_elements : $old_elements[-1];
 389 }
 390
 391 # We don't need to populate it, yet.
 392 # It will be useful, though, when we split out HASH and ARRAY
 393 sub EXTEND {
 394     warn "ARRAY::EXTEND()\n" if DBM::Deep::DEBUG;
 395     ##
 396     # Perl will call EXTEND() when the array is likely to grow.
 397     # We don't care, but include it because it gets called at times.
 398     ##
 399 }
 400
 401 sub _copy_node {
 402     my $self = shift;
 403     my ($db_temp) = @_;
 404
 405     my $length = $self->length();
 406     for (my $index = 0; $index < $length; $index++) {
 407         $self->_copy_value( \$db_temp->[$index], $self->get($index) );
 408     }
 409
 410     return 1;
 411 }
 412
 413 ##
 414 # Public method aliases
 415 ##
 416 sub length { (shift)->FETCHSIZE(@_) }
 417 sub pop { (shift)->POP(@_) }
 418 sub push { (shift)->PUSH(@_) }
 419 sub unshift { (shift)->UNSHIFT(@_) }
 420 sub splice { (shift)->SPLICE(@_) }
 421
 422 # This must be last otherwise we have to qualify all other calls to shift
 423 # as calls to CORE::shift
 424 sub shift { (CORE::shift)->SHIFT(@_) }
 425
 426 1;
 427 __END__