lib/DBM/Deep/Array.pm

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