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