[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 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;
    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::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::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;
    $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.
	##
#}

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