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