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