X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep%2FArray.pm;h=ae8dba814135c05c9aef2b2e6b0c5bc80f6cb253;hb=72e315ac5b05326d864abc064f4e660cd04768c7;hp=6c7d7d45204d9e584a94d1887725381d4b712ba4;hpb=0ca7ea98550b6f782b4b68be8b261218ff097f74;p=dbsrgits%2FDBM-Deep.git diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 6c7d7d4..ae8dba8 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -1,241 +1,330 @@ package DBM::Deep::Array; -$NEGATIVE_INDICES = 1; +use 5.6.0; use strict; +use warnings; + +our $VERSION = '0.99_01'; + +# 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. +our $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 _repr { shift;[ @_ ] } + +sub _import { + my $self = shift; + my ($struct) = @_; + + eval { + local $SIG{'__DIE__'}; + $self->push( @$struct ); + }; if ($@) { + $self->_throw_error("Cannot import: type mismatch"); + } + + return 1; +} sub TIEARRAY { -## -# Tied array constructor method, called by Perl's tie() function. -## my $class = shift; my $args = $class->_get_args( @_ ); - - $args->{type} = $class->TYPE_ARRAY; - - return $class->_init($args); + + $args->{type} = $class->TYPE_ARRAY; + + return $class->_init($args); } sub FETCH { - my $self = $_[0]->_get_self; - my $key = $_[1]; + my $self = shift->_get_self; + my ($key) = @_; + + $self->lock( $self->LOCK_SH ); +# my $orig_key = $key eq 'length' ? undef : $key; + my $orig_key = $key; if ( $key =~ /^-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; - return unless $key >= 0; + unless ( $key >= 0 ) { + $self->unlock; + return; + } } - $key = pack($DBM::Deep::LONG_PACK, $key); + $key = pack($self->_engine->{long_pack}, $key); } - return $self->SUPER::FETCH( $key ); + my $rv = $self->SUPER::FETCH( $key, $orig_key ); + + $self->unlock; + + return $rv; } sub STORE { my $self = shift->_get_self; my ($key, $value) = @_; - my $orig = $key; - my $size = $self->FETCHSIZE; + $self->lock( $self->LOCK_EX ); +# my $orig = $key eq 'length' ? undef : $key; + my $orig_key = $key; + + my $size; my $numeric_idx; - if ( $key =~ /^-?\d+$/ ) { + 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" ); + die( "Modification of non-creatable array value attempted, subscript $orig_key" ); } } - $key = pack($DBM::Deep::LONG_PACK, $key); + $key = pack($self->_engine->{long_pack}, $key); } - my $rv = $self->SUPER::STORE( $key, $value ); + my $rv = $self->SUPER::STORE( $key, $value, $orig_key ); - if ( $numeric_idx && $rv == 2 && $orig >= $size ) { - $self->STORESIZE( $orig + 1 ); + if ( $numeric_idx ) { + $size = $self->FETCHSIZE unless defined $size; + if ( $orig_key >= $size ) { + $self->STORESIZE( $orig_key + 1 ); + } } + $self->unlock; + return $rv; } sub EXISTS { - my $self = $_[0]->_get_self; - my $key = $_[1]; + my $self = shift->_get_self; + my ($key) = @_; - if ( $key =~ /^-?\d+$/ ) { + $self->lock( $self->LOCK_SH ); + + if ( $key =~ /^\-?\d+$/ ) { if ( $key < 0 ) { $key += $self->FETCHSIZE; - return unless $key >= 0; + unless ( $key >= 0 ) { + $self->unlock; + return; + } + } + + $key = pack($self->_engine->{long_pack}, $key); + } + + my $rv = $self->SUPER::EXISTS( $key ); + + $self->unlock; + + return $rv; +} + +sub DELETE { + my $self = shift->_get_self; + my ($key) = @_; + + my $unpacked_key = $key; + my $orig = $key eq 'length' ? undef : $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::LONG_PACK, $key); + $key = pack($self->_engine->{long_pack}, $key); } - return $self->SUPER::EXISTS( $key ); + my $rv = $self->SUPER::DELETE( $key, $orig ); + + 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 $packed_size = $self->FETCH('length'); - - $self->root->{filter_fetch_value} = $SAVE_FILTER; - - if ($packed_size) { - return int(unpack($DBM::Deep::LONG_PACK, $packed_size)); + my $self = shift->_get_self; + + $self->lock( $self->LOCK_SH ); + + my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value}; + $self->_fileobj->{filter_fetch_value} = undef; + + my $packed_size = $self->FETCH('length'); + + $self->_fileobj->{filter_fetch_value} = $SAVE_FILTER; + + $self->unlock; + + if ($packed_size) { + return int(unpack($self->_engine->{long_pack}, $packed_size)); } - return 0; + return 0; } sub STORESIZE { - ## - # Set the length of the array - ## - my $self = $_[0]->_get_self; - my $new_length = $_[1]; - - 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)); - - $self->root->{filter_store_value} = $SAVE_FILTER; - - return $result; + my $self = shift->_get_self; + my ($new_length) = @_; + + $self->lock( $self->LOCK_EX ); + + my $SAVE_FILTER = $self->_fileobj->{filter_store_value}; + $self->_fileobj->{filter_store_value} = undef; + + my $result = $self->STORE('length', pack($self->_engine->{long_pack}, $new_length), 'length'); + + $self->_fileobj->{filter_store_value} = $SAVE_FILTER; + + $self->unlock; + + return $result; } sub POP { - ## - # Remove and return the last element on the array - ## - my $self = $_[0]->_get_self; - my $length = $self->FETCHSIZE(); - - if ($length) { - my $content = $self->FETCH( $length - 1 ); - $self->DELETE( $length - 1 ); - return $content; - } - else { - return; - } + my $self = shift->_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; + } } sub PUSH { - ## - # Add new element(s) to the end of the array - ## my $self = shift->_get_self; - my $length = $self->FETCHSIZE(); - - while (my $content = shift @_) { - $self->STORE( $length, $content ); - $length++; - } + + $self->lock( $self->LOCK_EX ); + + my $length = $self->FETCHSIZE(); + + while (my $content = shift @_) { + $self->STORE( $length, $content ); + $length++; + } + + $self->unlock; return $length; } sub SHIFT { - ## - # Remove and return first element on the array. - # Shift over remaining elements to take up space. - ## - my $self = $_[0]->_get_self; - my $length = $self->FETCHSIZE(); - - if ($length) { - my $content = $self->FETCH( 0 ); - - ## - # Shift elements over and remove last one. - ## - for (my $i = 0; $i < $length - 1; $i++) { - $self->STORE( $i, $self->FETCH($i + 1) ); - } - $self->DELETE( $length - 1 ); - - return $content; - } - else { - return; - } + my $self = shift->_get_self; + + $self->lock( $self->LOCK_EX ); + + my $length = $self->FETCHSIZE(); + + if ($length) { + my $content = $self->FETCH( 0 ); + + for (my $i = 0; $i < $length - 1; $i++) { + $self->STORE( $i, $self->FETCH($i + 1) ); + } + $self->DELETE( $length - 1 ); + + $self->unlock; + + return $content; + } + else { + $self->unlock; + return; + } } sub UNSHIFT { - ## - # Insert new element(s) at beginning of array. - # Shift over other elements to make space. - ## my $self = shift->_get_self; - my @new_elements = @_; - my $length = $self->FETCHSIZE(); - my $new_size = scalar @new_elements; - - if ($length) { - for (my $i = $length - 1; $i >= 0; $i--) { - $self->STORE( $i + $new_size, $self->FETCH($i) ); - } - } - - for (my $i = 0; $i < $new_size; $i++) { - $self->STORE( $i, $new_elements[$i] ); - } + my @new_elements = @_; + + $self->lock( $self->LOCK_EX ); + + my $length = $self->FETCHSIZE(); + my $new_size = scalar @new_elements; + + if ($length) { + for (my $i = $length - 1; $i >= 0; $i--) { + $self->STORE( $i + $new_size, $self->FETCH($i) ); + } + } + + for (my $i = 0; $i < $new_size; $i++) { + $self->STORE( $i, $new_elements[$i] ); + } + + $self->unlock; return $length + $new_size; } sub SPLICE { - ## - # Splices section of array with optional new section. - # Returns deleted section, or last element deleted in scalar context. - ## my $self = shift->_get_self; - my $length = $self->FETCHSIZE(); - - ## - # Calculate offset and length of splice - ## - my $offset = shift || 0; - if ($offset < 0) { $offset += $length; } - - my $splice_length; - if (scalar @_) { $splice_length = shift; } - else { $splice_length = $length - $offset; } - if ($splice_length < 0) { $splice_length += ($length - $offset); } - - ## - # Setup array with new elements, and copy out old elements for return - ## - 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 ); - } - - ## - # Adjust array length, and shift elements to accomodate new section. - ## + + $self->lock( $self->LOCK_EX ); + + my $length = $self->FETCHSIZE(); + + ## + # Calculate offset and length of splice + ## + my $offset = shift; + $offset = 0 unless defined $offset; + if ($offset < 0) { $offset += $length; } + + my $splice_length; + if (scalar @_) { $splice_length = shift; } + else { $splice_length = $length - $offset; } + if ($splice_length < 0) { $splice_length += ($length - $offset); } + + ## + # Setup array with new elements, and copy out old elements for return + ## + my @new_elements = @_; + my $new_size = scalar @new_elements; + + my @old_elements = map { + $self->FETCH( $_ ) + } $offset .. ($offset + $splice_length - 1); + + ## + # Adjust array length, and shift elements to accomodate new section. + ## if ( $new_size != $splice_length ) { if ($new_size > $splice_length) { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { @@ -251,39 +340,57 @@ sub SPLICE { $length--; } } - } - - ## - # Insert new elements into array - ## - for (my $i = $offset; $i < $offset + $new_size; $i++) { - $self->STORE( $i, shift @new_elements ); - } - - ## - # Return deleted section, or last element in scalar context. - ## - return wantarray ? @old_elements : $old_elements[-1]; + } + + ## + # Insert new elements into array + ## + for (my $i = $offset; $i < $offset + $new_size; $i++) { + $self->STORE( $i, shift @new_elements ); + } + + $self->unlock; + + ## + # Return deleted section, or last element in scalar context. + ## + return wantarray ? @old_elements : $old_elements[-1]; +} + +# We don't need to define it, yet. +# It will be useful, though, when we split out HASH and ARRAY +sub EXTEND { + ## + # Perl will call EXTEND() when the array is likely to grow. + # We don't care, but include it because it gets called at times. + ## } -#XXX We don't need to define it. -#XXX It will be useful, though, when we split out HASH and ARRAY -#sub EXTEND { - ## - # Perl will call EXTEND() when the array is likely to grow. - # We don't care, but include it for compatibility. - ## -#} +sub _copy_node { + my $self = shift; + my ($db_temp) = @_; + + my $length = $self->length(); + for (my $index = 0; $index < $length; $index++) { + my $value = $self->get($index); + $self->_copy_value( \$db_temp->[$index], $value ); + } + + return 1; +} ## # Public method aliases ## -*length = *FETCHSIZE; -*pop = *POP; -*push = *PUSH; -*shift = *SHIFT; -*unshift = *UNSHIFT; -*splice = *SPLICE; +sub length { (shift)->FETCHSIZE(@_) } +sub pop { (shift)->POP(@_) } +sub push { (shift)->PUSH(@_) } +sub unshift { (shift)->UNSHIFT(@_) } +sub splice { (shift)->SPLICE(@_) } + +# This must be last otherwise we have to qualify all other calls to shift +# as calls to CORE::shift +sub shift { (CORE::shift)->SHIFT(@_) } 1; __END__