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