lib/DBM/Deep/Array.pm

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