lib/DBM/Deep/Array.pm

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