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