[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Array.pm

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 { 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);
}

sub FETCH {
    my $self = shift->_get_self;
    my ($key) = @_;

	$self->lock( $self->LOCK_SH );

    if ( $key =~ /^-?\d+$/ ) {
        if ( $key < 0 ) {
            $key += $self->FETCHSIZE;
            unless ( $key >= 0 ) {
                $self->unlock;
                return;
            }
        }

        $key = pack($self->{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($self->{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 = shift->_get_self;
    my ($key) = @_;

	$self->lock( $self->LOCK_SH );

    if ( $key =~ /^\-?\d+$/ ) {
        if ( $key < 0 ) {
            $key += $self->FETCHSIZE;
            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;

    $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($self->{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 = 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->unlock;

	if ($packed_size) {
        return int(unpack($self->{engine}{long_pack}, $packed_size));
    }

	return 0;
}

sub STORESIZE {
	##
	# Set the length of the array
	##
    my $self = shift->_get_self;
	my ($new_length) = @_;
	
    $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($self->{engine}{long_pack}, $new_length));
	
	$self->_root->{filter_store_value} = $SAVE_FILTER;
	
    $self->unlock;

	return $result;
}

sub POP {
	##
	# Remove and return the last element on the array
	##
    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;
	
    $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 = shift->_get_self;

    $self->lock( $self->LOCK_EX );

	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 );

        $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 = @_;

    $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;

    $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--) {
                $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
            }
        }
        else {
            for (my $i = $offset + $splice_length; $i < $length; $i++) {
                $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
            }
            for (my $i = 0; $i < $splice_length - $new_size; $i++) {
                $self->DELETE( $length - 1 );
                $length--;
            }
        }
	}
	
	##
	# 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];
}

#XXX We don't need to define it, yet.
#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->_get_self;
    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
##
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__
Commit	Line	Data
6fe26b29	1	package DBM::Deep::Array;
	2
	3	use strict;
	4
8fec41b9	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.
7910cf68	8	use vars qw( $NEGATIVE_INDICES );
	9	$NEGATIVE_INDICES = 1;
	10
6fe26b29	11	use base 'DBM::Deep';
6fe26b29	12
e1b265cc	13	use Scalar::Util ();
e1b265cc	14
596e9574	15	sub _get_self {
8db25060	16	eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } \|\| $_[0]
596e9574	17	}
596e9574	18
f9c33187	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	}
6fe26b29	34	sub TIEARRAY {
	35	##
	36	# Tied array constructor method, called by Perl's tie() function.
	37	##
	38	my $class = shift;
0ca7ea98	39	my $args = $class->_get_args( @_ );
6fe26b29	40
	41	$args->{type} = $class->TYPE_ARRAY;
	42
	43	return $class->_init($args);
	44	}
	45
7f441181	46	sub FETCH {
eea0d863	47	my $self = shift->_get_self;
eea0d863	48	my ($key) = @_;
7f441181	49
9281d66b	50	$self->lock( $self->LOCK_SH );
9a187d8c	51
7f441181	52	if ( $key =~ /^-?\d+$/ ) {
	53	if ( $key < 0 ) {
	54	$key += $self->FETCHSIZE;
9281d66b	55	unless ( $key >= 0 ) {
	56	$self->unlock;
	57	return;
	58	}
7f441181	59	}
7f441181	60
612969fb	61	$key = pack($self->{engine}{long_pack}, $key);
7f441181	62	}
7f441181	63
9281d66b	64	my $rv = $self->SUPER::FETCH( $key );
	65
	66	$self->unlock;
	67
	68	return $rv;
7f441181	69	}
7f441181	70
cb79ec85	71	sub STORE {
	72	my $self = shift->_get_self;
	73	my ($key, $value) = @_;
	74
9281d66b	75	$self->lock( $self->LOCK_EX );
9281d66b	76
baa27ab6	77	my $orig = $key;
cb79ec85	78
9ab67b8c	79	my $size;
cb79ec85	80	my $numeric_idx;
9ab67b8c	81	if ( $key =~ /^\-?\d+$/ ) {
cb79ec85	82	$numeric_idx = 1;
cb79ec85	83	if ( $key < 0 ) {
9ab67b8c	84	$size = $self->FETCHSIZE;
cb79ec85	85	$key += $size;
baa27ab6	86	if ( $key < 0 ) {
	87	die( "Modification of non-creatable array value attempted, subscript $orig" );
	88	}
cb79ec85	89	}
cb79ec85	90
612969fb	91	$key = pack($self->{engine}{long_pack}, $key);
cb79ec85	92	}
	93
	94	my $rv = $self->SUPER::STORE( $key, $value );
	95
9ab67b8c	96	if ( $numeric_idx && $rv == 2 ) {
	97	$size = $self->FETCHSIZE unless defined $size;
	98	if ( $orig >= $size ) {
	99	$self->STORESIZE( $orig + 1 );
	100	}
cb79ec85	101	}
cb79ec85	102
9281d66b	103	$self->unlock;
9281d66b	104
cb79ec85	105	return $rv;
	106	}
	107
baa27ab6	108	sub EXISTS {
eea0d863	109	my $self = shift->_get_self;
eea0d863	110	my ($key) = @_;
baa27ab6	111
9281d66b	112	$self->lock( $self->LOCK_SH );
9281d66b	113
9ab67b8c	114	if ( $key =~ /^\-?\d+$/ ) {
baa27ab6	115	if ( $key < 0 ) {
baa27ab6	116	$key += $self->FETCHSIZE;
9281d66b	117	unless ( $key >= 0 ) {
	118	$self->unlock;
	119	return;
	120	}
	121	}
	122
612969fb	123	$key = pack($self->{engine}{long_pack}, $key);
9281d66b	124	}
	125
	126	my $rv = $self->SUPER::EXISTS( $key );
	127
	128	$self->unlock;
	129
	130	return $rv;
	131	}
	132
	133	sub DELETE {
eea0d863	134	my $self = shift->_get_self;
eea0d863	135	my ($key) = @_;
9281d66b	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	}
baa27ab6	149	}
baa27ab6	150
612969fb	151	$key = pack($self->{engine}{long_pack}, $key);
baa27ab6	152	}
baa27ab6	153
9281d66b	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;
baa27ab6	163	}
baa27ab6	164
6fe26b29	165	sub FETCHSIZE {
	166	##
	167	# Return the length of the array
	168	##
9281d66b	169	my $self = shift->_get_self;
	170
	171	$self->lock( $self->LOCK_SH );
	172
4d35d856	173	my $SAVE_FILTER = $self->_root->{filter_fetch_value};
4d35d856	174	$self->_root->{filter_fetch_value} = undef;
6fe26b29	175
	176	my $packed_size = $self->FETCH('length');
	177
4d35d856	178	$self->_root->{filter_fetch_value} = $SAVE_FILTER;
6fe26b29	179
9281d66b	180	$self->unlock;
9281d66b	181
7f441181	182	if ($packed_size) {
612969fb	183	return int(unpack($self->{engine}{long_pack}, $packed_size));
7f441181	184	}
cb79ec85	185
cb79ec85	186	return 0;
6fe26b29	187	}
	188
	189	sub STORESIZE {
	190	##
	191	# Set the length of the array
	192	##
eea0d863	193	my $self = shift->_get_self;
eea0d863	194	my ($new_length) = @_;
6fe26b29	195
9281d66b	196	$self->lock( $self->LOCK_EX );
9281d66b	197
4d35d856	198	my $SAVE_FILTER = $self->_root->{filter_store_value};
4d35d856	199	$self->_root->{filter_store_value} = undef;
6fe26b29	200
612969fb	201	my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
6fe26b29	202
4d35d856	203	$self->_root->{filter_store_value} = $SAVE_FILTER;
6fe26b29	204
9281d66b	205	$self->unlock;
9281d66b	206
6fe26b29	207	return $result;
	208	}
	209
	210	sub POP {
	211	##
	212	# Remove and return the last element on the array
	213	##
eea0d863	214	my $self = shift->_get_self;
9281d66b	215
	216	$self->lock( $self->LOCK_EX );
	217
6fe26b29	218	my $length = $self->FETCHSIZE();
	219
	220	if ($length) {
	221	my $content = $self->FETCH( $length - 1 );
	222	$self->DELETE( $length - 1 );
9281d66b	223
	224	$self->unlock;
	225
6fe26b29	226	return $content;
	227	}
	228	else {
9281d66b	229	$self->unlock;
6fe26b29	230	return;
	231	}
	232	}
	233
	234	sub PUSH {
	235	##
	236	# Add new element(s) to the end of the array
	237	##
2ac02042	238	my $self = shift->_get_self;
6fe26b29	239
9281d66b	240	$self->lock( $self->LOCK_EX );
	241
	242	my $length = $self->FETCHSIZE();
	243
6fe26b29	244	while (my $content = shift @_) {
	245	$self->STORE( $length, $content );
	246	$length++;
	247	}
8f6d6ed0	248
9281d66b	249	$self->unlock;
9281d66b	250
8f6d6ed0	251	return $length;
6fe26b29	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	##
eea0d863	259	my $self = shift->_get_self;
9281d66b	260
	261	$self->lock( $self->LOCK_EX );
	262
6fe26b29	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 );
9281d66b	275
9281d66b	276	$self->unlock;
6fe26b29	277
	278	return $content;
	279	}
	280	else {
9281d66b	281	$self->unlock;
6fe26b29	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	##
2ac02042	291	my $self = shift->_get_self;
6fe26b29	292	my @new_elements = @_;
9281d66b	293
	294	$self->lock( $self->LOCK_EX );
	295
6fe26b29	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	}
8f6d6ed0	308
9281d66b	309	$self->unlock;
9281d66b	310
8f6d6ed0	311	return $length + $new_size;
6fe26b29	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	##
2ac02042	319	my $self = shift->_get_self;
9281d66b	320
	321	$self->lock( $self->LOCK_EX );
	322
6fe26b29	323	my $length = $self->FETCHSIZE();
	324
	325	##
	326	# Calculate offset and length of splice
	327	##
714618f0	328	my $offset = shift;
714618f0	329	$offset = 0 unless defined $offset;
6fe26b29	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
df3c5701	343	my @old_elements = map {
	344	$self->FETCH( $_ )
	345	} $offset .. ($offset + $splice_length - 1);
6fe26b29	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
9281d66b	374	$self->unlock;
9281d66b	375
6fe26b29	376	##
	377	# Return deleted section, or last element in scalar context.
	378	##
	379	return wantarray ? @old_elements : $old_elements[-1];
	380	}
	381
9281d66b	382	#XXX We don't need to define it, yet.
6fe26b29	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
f9c33187	391	sub _copy_node {
	392	my $self = shift->_get_self;
	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
6fe26b29	404	##
	405	# Public method aliases
	406	##
f9c33187	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
f75b719e	415	sub shift { (CORE::shift)->SHIFT(@_) }
6fe26b29	416
	417	1;
	418	__END__