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