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