lib/DBM/Deep/Array.pm

   1 package DBM::Deep::Array;
   2
   3 use strict;
   4
   5 # This is to allow DBM::Deep::Array to handle negative indices on
   6 # its own. Otherwise, Perl would intercept the call to negative
   7 # indices for us. This was causing bugs for negative index handling.
   8 use vars qw( $NEGATIVE_INDICES );
   9 $NEGATIVE_INDICES = 1;
  10
  11 use base 'DBM::Deep';
  12
  13 use Scalar::Util ();
  14
  15 sub _get_self {
  16     eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
  17 }
  18
  19 sub TIEARRAY {
  20 ##
  21 # Tied array constructor method, called by Perl's tie() function.
  22 ##
  23     my $class = shift;
  24     my $args = $class->_get_args( @_ );
  25
  26         $args->{type} = $class->TYPE_ARRAY;
  27
  28         return $class->_init($args);
  29 }
  30
  31 sub FETCH {
  32     my $self = shift->_get_self;
  33     my ($key) = @_;
  34
  35         $self->lock( $self->LOCK_SH );
  36
  37     if ( $key =~ /^-?\d+$/ ) {
  38         if ( $key < 0 ) {
  39             $key += $self->FETCHSIZE;
  40             unless ( $key >= 0 ) {
  41                 $self->unlock;
  42                 return;
  43             }
  44         }
  45
  46         $key = pack($self->{engine}{long_pack}, $key);
  47     }
  48
  49     my $rv = $self->SUPER::FETCH( $key );
  50
  51     $self->unlock;
  52
  53     return $rv;
  54 }
  55
  56 sub STORE {
  57     my $self = shift->_get_self;
  58     my ($key, $value) = @_;
  59
  60     $self->lock( $self->LOCK_EX );
  61
  62     my $orig = $key;
  63
  64     my $size;
  65     my $numeric_idx;
  66     if ( $key =~ /^\-?\d+$/ ) {
  67         $numeric_idx = 1;
  68         if ( $key < 0 ) {
  69             $size = $self->FETCHSIZE;
  70             $key += $size;
  71             if ( $key < 0 ) {
  72                 die( "Modification of non-creatable array value attempted, subscript $orig" );
  73             }
  74         }
  75
  76         $key = pack($self->{engine}{long_pack}, $key);
  77     }
  78
  79     my $rv = $self->SUPER::STORE( $key, $value );
  80
  81     if ( $numeric_idx && $rv == 2 ) {
  82         $size = $self->FETCHSIZE unless defined $size;
  83         if ( $orig >= $size ) {
  84             $self->STORESIZE( $orig + 1 );
  85         }
  86     }
  87
  88     $self->unlock;
  89
  90     return $rv;
  91 }
  92
  93 sub EXISTS {
  94     my $self = shift->_get_self;
  95     my ($key) = @_;
  96
  97         $self->lock( $self->LOCK_SH );
  98
  99     if ( $key =~ /^\-?\d+$/ ) {
 100         if ( $key < 0 ) {
 101             $key += $self->FETCHSIZE;
 102             unless ( $key >= 0 ) {
 103                 $self->unlock;
 104                 return;
 105             }
 106         }
 107
 108         $key = pack($self->{engine}{long_pack}, $key);
 109     }
 110
 111     my $rv = $self->SUPER::EXISTS( $key );
 112
 113     $self->unlock;
 114
 115     return $rv;
 116 }
 117
 118 sub DELETE {
 119     my $self = shift->_get_self;
 120     my ($key) = @_;
 121
 122     my $unpacked_key = $key;
 123
 124     $self->lock( $self->LOCK_EX );
 125
 126     my $size = $self->FETCHSIZE;
 127     if ( $key =~ /^-?\d+$/ ) {
 128         if ( $key < 0 ) {
 129             $key += $size;
 130             unless ( $key >= 0 ) {
 131                 $self->unlock;
 132                 return;
 133             }
 134         }
 135
 136         $key = pack($self->{engine}{long_pack}, $key);
 137     }
 138
 139     my $rv = $self->SUPER::DELETE( $key );
 140
 141         if ($rv && $unpacked_key == $size - 1) {
 142                 $self->STORESIZE( $unpacked_key );
 143         }
 144
 145     $self->unlock;
 146
 147     return $rv;
 148 }
 149
 150 sub FETCHSIZE {
 151         ##
 152         # Return the length of the array
 153         ##
 154     my $self = shift->_get_self;
 155
 156     $self->lock( $self->LOCK_SH );
 157
 158         my $SAVE_FILTER = $self->_root->{filter_fetch_value};
 159         $self->_root->{filter_fetch_value} = undef;
 160
 161         my $packed_size = $self->FETCH('length');
 162
 163         $self->_root->{filter_fetch_value} = $SAVE_FILTER;
 164
 165     $self->unlock;
 166
 167         if ($packed_size) {
 168         return int(unpack($self->{engine}{long_pack}, $packed_size));
 169     }
 170
 171         return 0;
 172 }
 173
 174 sub STORESIZE {
 175         ##
 176         # Set the length of the array
 177         ##
 178     my $self = shift->_get_self;
 179         my ($new_length) = @_;
 180
 181     $self->lock( $self->LOCK_EX );
 182
 183         my $SAVE_FILTER = $self->_root->{filter_store_value};
 184         $self->_root->{filter_store_value} = undef;
 185
 186         my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
 187
 188         $self->_root->{filter_store_value} = $SAVE_FILTER;
 189
 190     $self->unlock;
 191
 192         return $result;
 193 }
 194
 195 sub POP {
 196         ##
 197         # Remove and return the last element on the array
 198         ##
 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         ##
 221         # Add new element(s) to the end of the array
 222         ##
 223     my $self = shift->_get_self;
 224
 225     $self->lock( $self->LOCK_EX );
 226
 227         my $length = $self->FETCHSIZE();
 228
 229         while (my $content = shift @_) {
 230                 $self->STORE( $length, $content );
 231                 $length++;
 232         }
 233
 234     $self->unlock;
 235
 236     return $length;
 237 }
 238
 239 sub SHIFT {
 240         ##
 241         # Remove and return first element on the array.
 242         # Shift over remaining elements to take up space.
 243         ##
 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                 ##
 254                 # Shift elements over and remove last one.
 255                 ##
 256                 for (my $i = 0; $i < $length - 1; $i++) {
 257                         $self->STORE( $i, $self->FETCH($i + 1) );
 258                 }
 259                 $self->DELETE( $length - 1 );
 260
 261         $self->unlock;
 262
 263                 return $content;
 264         }
 265         else {
 266         $self->unlock;
 267                 return;
 268         }
 269 }
 270
 271 sub UNSHIFT {
 272         ##
 273         # Insert new element(s) at beginning of array.
 274         # Shift over other elements to make space.
 275         ##
 276     my $self = shift->_get_self;
 277         my @new_elements = @_;
 278
 279     $self->lock( $self->LOCK_EX );
 280
 281         my $length = $self->FETCHSIZE();
 282         my $new_size = scalar @new_elements;
 283
 284         if ($length) {
 285                 for (my $i = $length - 1; $i >= 0; $i--) {
 286                         $self->STORE( $i + $new_size, $self->FETCH($i) );
 287                 }
 288         }
 289
 290         for (my $i = 0; $i < $new_size; $i++) {
 291                 $self->STORE( $i, $new_elements[$i] );
 292         }
 293
 294     $self->unlock;
 295
 296     return $length + $new_size;
 297 }
 298
 299 sub SPLICE {
 300         ##
 301         # Splices section of array with optional new section.
 302         # Returns deleted section, or last element deleted in scalar context.
 303         ##
 304     my $self = shift->_get_self;
 305
 306     $self->lock( $self->LOCK_EX );
 307
 308         my $length = $self->FETCHSIZE();
 309
 310         ##
 311         # Calculate offset and length of splice
 312         ##
 313         my $offset = shift;
 314     $offset = 0 unless defined $offset;
 315         if ($offset < 0) { $offset += $length; }
 316
 317         my $splice_length;
 318         if (scalar @_) { $splice_length = shift; }
 319         else { $splice_length = $length - $offset; }
 320         if ($splice_length < 0) { $splice_length += ($length - $offset); }
 321
 322         ##
 323         # Setup array with new elements, and copy out old elements for return
 324         ##
 325         my @new_elements = @_;
 326         my $new_size = scalar @new_elements;
 327
 328     my @old_elements = map {
 329         $self->FETCH( $_ )
 330     } $offset .. ($offset + $splice_length - 1);
 331
 332         ##
 333         # Adjust array length, and shift elements to accomodate new section.
 334         ##
 335     if ( $new_size != $splice_length ) {
 336         if ($new_size > $splice_length) {
 337             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
 338                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 339             }
 340         }
 341         else {
 342             for (my $i = $offset + $splice_length; $i < $length; $i++) {
 343                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
 344             }
 345             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
 346                 $self->DELETE( $length - 1 );
 347                 $length--;
 348             }
 349         }
 350         }
 351
 352         ##
 353         # Insert new elements into array
 354         ##
 355         for (my $i = $offset; $i < $offset + $new_size; $i++) {
 356                 $self->STORE( $i, shift @new_elements );
 357         }
 358
 359     $self->unlock;
 360
 361         ##
 362         # Return deleted section, or last element in scalar context.
 363         ##
 364         return wantarray ? @old_elements : $old_elements[-1];
 365 }
 366
 367 #XXX We don't need to define it, yet.
 368 #XXX It will be useful, though, when we split out HASH and ARRAY
 369 #sub EXTEND {
 370         ##
 371         # Perl will call EXTEND() when the array is likely to grow.
 372         # We don't care, but include it for compatibility.
 373         ##
 374 #}
 375
 376 ##
 377 # Public method aliases
 378 ##
 379 sub length { (CORE::shift)->FETCHSIZE(@_) }
 380 sub pop { (CORE::shift)->POP(@_) }
 381 sub push { (CORE::shift)->PUSH(@_) }
 382 sub shift { (CORE::shift)->SHIFT(@_) }
 383 sub unshift { (CORE::shift)->UNSHIFT(@_) }
 384 sub splice { (CORE::shift)->SPLICE(@_) }
 385
 386 1;
 387 __END__