[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 { tied( @{$_[0]} ) } || $_[0]
}

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 = $_[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::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 = $self->FETCHSIZE;

    my $numeric_idx;
    if ( $key =~ /^-?\d+$/ ) {
        $numeric_idx = 1;
        if ( $key < 0 ) {
            $key += $size;
            if ( $key < 0 ) {
                die( "Modification of non-creatable array value attempted, subscript $orig" );
            }
        }

        $key = pack($DBM::Deep::LONG_PACK, $key);
    }

    my $rv = $self->SUPER::STORE( $key, $value );

    if ( $numeric_idx && $rv == 2 && $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::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::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($DBM::Deep::LONG_PACK, $packed_size));
    }

	return 0;
}

sub STORESIZE {
	##
	# Set the length of the array
	##
    my $self = $_[0]->_get_self;
	my $new_length = $_[1];
	
    $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));
	
	$self->root->{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;

    $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 = $_[0]->_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 || 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.
	##
    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.
	##
#}

##
# Public method aliases
##
*length = *FETCHSIZE;
*pop = *POP;
*push = *PUSH;
*shift = *SHIFT;
*unshift = *UNSHIFT;
*splice = *SPLICE;

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