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