lib/DBM/Deep/Array.pm

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