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