X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep%2FArray.pm;h=0087ccc6d13a42b800a91426f75b21d4c97997f0;hb=70b5542878eb8e2e68692982806ab90c7879e0c7;hp=9f11127108a1941abac671608471cc475d3b4b13;hpb=2ac020421a5a06ac144cfe6650ff0a2738c74448;p=dbsrgits%2FDBM-Deep.git diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 9f11127..0087ccc 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -2,10 +2,18 @@ package DBM::Deep::Array; use strict; +# This is to allow DBM::Deep::Array to handle negative indices on +# its own. Otherwise, Perl would intercept the call to negative +# indices for us. This was causing bugs for negative index handling. +use vars qw( $NEGATIVE_INDICES ); +$NEGATIVE_INDICES = 1; + use base 'DBM::Deep'; +use Scalar::Util (); + sub _get_self { - eval { tied( @{$_[0]} ) } || $_[0] + eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] } sub TIEARRAY { @@ -13,36 +21,154 @@ sub TIEARRAY { # Tied array constructor method, called by Perl's tie() function. ## my $class = shift; - my $args; - if (scalar(@_) > 1) { $args = {@_}; } - #XXX This use of ref() is bad and is a bug - elsif (ref($_[0])) { $args = $_[0]; } - else { $args = { file => shift }; } + my $args = $class->_get_args( @_ ); $args->{type} = $class->TYPE_ARRAY; return $class->_init($args); } -## -# The following methods are for arrays only -## +sub FETCH { + my $self = $_[0]->_get_self; + my $key = $_[1]; + + $self->lock( $self->LOCK_SH ); + + if ( $key =~ /^-?\d+$/ ) { + if ( $key < 0 ) { + $key += $self->FETCHSIZE; + unless ( $key >= 0 ) { + $self->unlock; + return; + } + } + + $key = pack($DBM::Deep::Engine::LONG_PACK, $key); + } + + my $rv = $self->SUPER::FETCH( $key ); + + $self->unlock; + + return $rv; +} + +sub STORE { + my $self = shift->_get_self; + my ($key, $value) = @_; + + $self->lock( $self->LOCK_EX ); + + my $orig = $key; + + my $size; + my $numeric_idx; + if ( $key =~ /^\-?\d+$/ ) { + $numeric_idx = 1; + if ( $key < 0 ) { + $size = $self->FETCHSIZE; + $key += $size; + if ( $key < 0 ) { + die( "Modification of non-creatable array value attempted, subscript $orig" ); + } + } + + $key = pack($DBM::Deep::Engine::LONG_PACK, $key); + } + + my $rv = $self->SUPER::STORE( $key, $value ); + + if ( $numeric_idx && $rv == 2 ) { + $size = $self->FETCHSIZE unless defined $size; + if ( $orig >= $size ) { + $self->STORESIZE( $orig + 1 ); + } + } + + $self->unlock; + + return $rv; +} + +sub EXISTS { + my $self = $_[0]->_get_self; + my $key = $_[1]; + + $self->lock( $self->LOCK_SH ); + + if ( $key =~ /^\-?\d+$/ ) { + if ( $key < 0 ) { + $key += $self->FETCHSIZE; + unless ( $key >= 0 ) { + $self->unlock; + return; + } + } + + $key = pack($DBM::Deep::Engine::LONG_PACK, $key); + } + + my $rv = $self->SUPER::EXISTS( $key ); + + $self->unlock; + + return $rv; +} + +sub DELETE { + my $self = $_[0]->_get_self; + my $key = $_[1]; + + my $unpacked_key = $key; + + $self->lock( $self->LOCK_EX ); + + my $size = $self->FETCHSIZE; + if ( $key =~ /^-?\d+$/ ) { + if ( $key < 0 ) { + $key += $size; + unless ( $key >= 0 ) { + $self->unlock; + return; + } + } + + $key = pack($DBM::Deep::Engine::LONG_PACK, $key); + } + + my $rv = $self->SUPER::DELETE( $key ); + + if ($rv && $unpacked_key == $size - 1) { + $self->STORESIZE( $unpacked_key ); + } + + $self->unlock; + + return $rv; +} sub FETCHSIZE { ## # Return the length of the array ## - my $self = $_[0]->_get_self; - - my $SAVE_FILTER = $self->root->{filter_fetch_value}; - $self->root->{filter_fetch_value} = undef; + my $self = shift->_get_self; + + $self->lock( $self->LOCK_SH ); + + my $SAVE_FILTER = $self->_root->{filter_fetch_value}; + $self->_root->{filter_fetch_value} = undef; my $packed_size = $self->FETCH('length'); - $self->root->{filter_fetch_value} = $SAVE_FILTER; + $self->_root->{filter_fetch_value} = $SAVE_FILTER; - if ($packed_size) { return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); } - else { return 0; } + $self->unlock; + + if ($packed_size) { + return int(unpack($DBM::Deep::Engine::LONG_PACK, $packed_size)); + } + + return 0; } sub STORESIZE { @@ -52,13 +178,17 @@ sub STORESIZE { my $self = $_[0]->_get_self; my $new_length = $_[1]; - my $SAVE_FILTER = $self->root->{filter_store_value}; - $self->root->{filter_store_value} = undef; + $self->lock( $self->LOCK_EX ); + + my $SAVE_FILTER = $self->_root->{filter_store_value}; + $self->_root->{filter_store_value} = undef; - my $result = $self->STORE('length', pack($DBM::Deep::LONG_PACK, $new_length)); + my $result = $self->STORE('length', pack($DBM::Deep::Engine::LONG_PACK, $new_length)); - $self->root->{filter_store_value} = $SAVE_FILTER; + $self->_root->{filter_store_value} = $SAVE_FILTER; + $self->unlock; + return $result; } @@ -67,14 +197,21 @@ sub POP { # Remove and return the last element on the array ## my $self = $_[0]->_get_self; + + $self->lock( $self->LOCK_EX ); + my $length = $self->FETCHSIZE(); if ($length) { my $content = $self->FETCH( $length - 1 ); $self->DELETE( $length - 1 ); + + $self->unlock; + return $content; } else { + $self->unlock; return; } } @@ -84,12 +221,19 @@ sub PUSH { # Add new element(s) to the end of the array ## my $self = shift->_get_self; - my $length = $self->FETCHSIZE(); + $self->lock( $self->LOCK_EX ); + + my $length = $self->FETCHSIZE(); + while (my $content = shift @_) { $self->STORE( $length, $content ); $length++; } + + $self->unlock; + + return $length; } sub SHIFT { @@ -98,6 +242,9 @@ sub SHIFT { # Shift over remaining elements to take up space. ## my $self = $_[0]->_get_self; + + $self->lock( $self->LOCK_EX ); + my $length = $self->FETCHSIZE(); if ($length) { @@ -110,10 +257,13 @@ sub SHIFT { $self->STORE( $i, $self->FETCH($i + 1) ); } $self->DELETE( $length - 1 ); + + $self->unlock; return $content; } else { + $self->unlock; return; } } @@ -125,6 +275,9 @@ sub UNSHIFT { ## my $self = shift->_get_self; my @new_elements = @_; + + $self->lock( $self->LOCK_EX ); + my $length = $self->FETCHSIZE(); my $new_size = scalar @new_elements; @@ -137,6 +290,10 @@ sub UNSHIFT { for (my $i = 0; $i < $new_size; $i++) { $self->STORE( $i, $new_elements[$i] ); } + + $self->unlock; + + return $length + $new_size; } sub SPLICE { @@ -145,12 +302,16 @@ sub SPLICE { # Returns deleted section, or last element deleted in scalar context. ## my $self = shift->_get_self; + + $self->lock( $self->LOCK_EX ); + my $length = $self->FETCHSIZE(); ## # Calculate offset and length of splice ## - my $offset = shift || 0; + my $offset = shift; + $offset = 0 unless defined $offset; if ($offset < 0) { $offset += $length; } my $splice_length; @@ -164,10 +325,9 @@ sub SPLICE { my @new_elements = @_; my $new_size = scalar @new_elements; - my @old_elements = (); - for (my $i = $offset; $i < $offset + $splice_length; $i++) { - push @old_elements, $self->FETCH( $i ); - } + my @old_elements = map { + $self->FETCH( $_ ) + } $offset .. ($offset + $splice_length - 1); ## # Adjust array length, and shift elements to accomodate new section. @@ -196,13 +356,15 @@ sub SPLICE { $self->STORE( $i, shift @new_elements ); } + $self->unlock; + ## # Return deleted section, or last element in scalar context. ## return wantarray ? @old_elements : $old_elements[-1]; } -#XXX We don't need to define it. +#XXX We don't need to define it, yet. #XXX It will be useful, though, when we split out HASH and ARRAY #sub EXTEND { ##