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