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