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

package DBM::Deep::Array;

use 5.6.0;

use strict;
use warnings;

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

    my $orig_key = $key eq 'length' ? undef : $key;
    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, $orig_key );

    $self->unlock;

    return $rv;
}

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

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

    my $orig = $key eq 'length' ? undef : $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, $orig );

    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;
    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($self->{engine}{long_pack}, $key);
    }

    my $rv = $self->SUPER::DELETE( $key, $orig );

	if ($rv && $unpacked_key == $size - 1) {
		$self->STORESIZE( $unpacked_key );
	}

    $self->unlock;

    return $rv;
}

sub FETCHSIZE {
    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;
}

sub STORESIZE {
    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));
	
	$self->_fileobj->{filter_store_value} = $SAVE_FILTER;
	
    $self->unlock;

	return $result;
}

sub POP {
    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 {
    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 {
    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 {
    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 {
    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];
}

# 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.
	##
}

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
##
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;
6fe26b29	2
460b1067	3	use 5.6.0;
460b1067	4
6fe26b29	5	use strict;
460b1067	6	use warnings;
6fe26b29	7
8fec41b9	8	# This is to allow DBM::Deep::Array to handle negative indices on
	9	# its own. Otherwise, Perl would intercept the call to negative
	10	# indices for us. This was causing bugs for negative index handling.
460b1067	11	our $NEGATIVE_INDICES = 1;
7910cf68	12
6fe26b29	13	use base 'DBM::Deep';
6fe26b29	14
e1b265cc	15	use Scalar::Util ();
e1b265cc	16
596e9574	17	sub _get_self {
8db25060	18	eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } \|\| $_[0]
596e9574	19	}
596e9574	20
f9c33187	21	sub _repr { shift;[ @_ ] }
	22
	23	sub _import {
	24	my $self = shift;
	25	my ($struct) = @_;
	26
	27	eval {
	28	local $SIG{'__DIE__'};
	29	$self->push( @$struct );
	30	}; if ($@) {
	31	$self->_throw_error("Cannot import: type mismatch");
	32	}
	33
	34	return 1;
	35	}
6fe26b29	36	sub TIEARRAY {
6fe26b29	37	my $class = shift;
0ca7ea98	38	my $args = $class->_get_args( @_ );
6fe26b29	39
	40	$args->{type} = $class->TYPE_ARRAY;
	41
	42	return $class->_init($args);
	43	}
	44
7f441181	45	sub FETCH {
eea0d863	46	my $self = shift->_get_self;
eea0d863	47	my ($key) = @_;
7f441181	48
9281d66b	49	$self->lock( $self->LOCK_SH );
9a187d8c	50
cfd97a7f	51	my $orig_key = $key eq 'length' ? undef : $key;
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
cfd97a7f	64	my $rv = $self->SUPER::FETCH( $key, $orig_key );
9281d66b	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
359a01ac	77	my $orig = $key eq 'length' ? undef : $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	}
cb79ec85	93
359a01ac	94	my $rv = $self->SUPER::STORE( $key, $value, $orig );
cb79ec85	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
9281d66b	137	my $unpacked_key = $key;
a97c8f67	138	my $orig = $key eq 'length' ? undef : $key;
9281d66b	139
	140	$self->lock( $self->LOCK_EX );
	141
	142	my $size = $self->FETCHSIZE;
	143	if ( $key =~ /^-?\d+$/ ) {
	144	if ( $key < 0 ) {
	145	$key += $size;
	146	unless ( $key >= 0 ) {
	147	$self->unlock;
	148	return;
	149	}
baa27ab6	150	}
baa27ab6	151
612969fb	152	$key = pack($self->{engine}{long_pack}, $key);
baa27ab6	153	}
baa27ab6	154
a97c8f67	155	my $rv = $self->SUPER::DELETE( $key, $orig );
9281d66b	156
	157	if ($rv && $unpacked_key == $size - 1) {
	158	$self->STORESIZE( $unpacked_key );
	159	}
	160
	161	$self->unlock;
	162
	163	return $rv;
baa27ab6	164	}
baa27ab6	165
6fe26b29	166	sub FETCHSIZE {
9281d66b	167	my $self = shift->_get_self;
	168
	169	$self->lock( $self->LOCK_SH );
	170
460b1067	171	my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value};
460b1067	172	$self->_fileobj->{filter_fetch_value} = undef;
6fe26b29	173
	174	my $packed_size = $self->FETCH('length');
	175
460b1067	176	$self->_fileobj->{filter_fetch_value} = $SAVE_FILTER;
6fe26b29	177
9281d66b	178	$self->unlock;
9281d66b	179
7f441181	180	if ($packed_size) {
612969fb	181	return int(unpack($self->{engine}{long_pack}, $packed_size));
7f441181	182	}
cb79ec85	183
cb79ec85	184	return 0;
6fe26b29	185	}
	186
	187	sub STORESIZE {
eea0d863	188	my $self = shift->_get_self;
eea0d863	189	my ($new_length) = @_;
6fe26b29	190
9281d66b	191	$self->lock( $self->LOCK_EX );
9281d66b	192
460b1067	193	my $SAVE_FILTER = $self->_fileobj->{filter_store_value};
460b1067	194	$self->_fileobj->{filter_store_value} = undef;
6fe26b29	195
612969fb	196	my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
6fe26b29	197
460b1067	198	$self->_fileobj->{filter_store_value} = $SAVE_FILTER;
6fe26b29	199
9281d66b	200	$self->unlock;
9281d66b	201
6fe26b29	202	return $result;
	203	}
	204
	205	sub POP {
eea0d863	206	my $self = shift->_get_self;
9281d66b	207
	208	$self->lock( $self->LOCK_EX );
	209
6fe26b29	210	my $length = $self->FETCHSIZE();
	211
	212	if ($length) {
	213	my $content = $self->FETCH( $length - 1 );
	214	$self->DELETE( $length - 1 );
9281d66b	215
	216	$self->unlock;
	217
6fe26b29	218	return $content;
	219	}
	220	else {
9281d66b	221	$self->unlock;
6fe26b29	222	return;
	223	}
	224	}
	225
	226	sub PUSH {
2ac02042	227	my $self = shift->_get_self;
6fe26b29	228
9281d66b	229	$self->lock( $self->LOCK_EX );
	230
	231	my $length = $self->FETCHSIZE();
	232
6fe26b29	233	while (my $content = shift @_) {
	234	$self->STORE( $length, $content );
	235	$length++;
	236	}
8f6d6ed0	237
9281d66b	238	$self->unlock;
9281d66b	239
8f6d6ed0	240	return $length;
6fe26b29	241	}
	242
	243	sub SHIFT {
eea0d863	244	my $self = shift->_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
6fe26b29	253	for (my $i = 0; $i < $length - 1; $i++) {
	254	$self->STORE( $i, $self->FETCH($i + 1) );
	255	}
	256	$self->DELETE( $length - 1 );
9281d66b	257
9281d66b	258	$self->unlock;
6fe26b29	259
	260	return $content;
	261	}
	262	else {
9281d66b	263	$self->unlock;
6fe26b29	264	return;
	265	}
	266	}
	267
	268	sub UNSHIFT {
2ac02042	269	my $self = shift->_get_self;
6fe26b29	270	my @new_elements = @_;
9281d66b	271
	272	$self->lock( $self->LOCK_EX );
	273
6fe26b29	274	my $length = $self->FETCHSIZE();
	275	my $new_size = scalar @new_elements;
	276
	277	if ($length) {
	278	for (my $i = $length - 1; $i >= 0; $i--) {
	279	$self->STORE( $i + $new_size, $self->FETCH($i) );
	280	}
	281	}
	282
	283	for (my $i = 0; $i < $new_size; $i++) {
	284	$self->STORE( $i, $new_elements[$i] );
	285	}
8f6d6ed0	286
9281d66b	287	$self->unlock;
9281d66b	288
8f6d6ed0	289	return $length + $new_size;
6fe26b29	290	}
	291
	292	sub SPLICE {
2ac02042	293	my $self = shift->_get_self;
9281d66b	294
	295	$self->lock( $self->LOCK_EX );
	296
6fe26b29	297	my $length = $self->FETCHSIZE();
	298
	299	##
	300	# Calculate offset and length of splice
	301	##
714618f0	302	my $offset = shift;
714618f0	303	$offset = 0 unless defined $offset;
6fe26b29	304	if ($offset < 0) { $offset += $length; }
	305
	306	my $splice_length;
	307	if (scalar @_) { $splice_length = shift; }
	308	else { $splice_length = $length - $offset; }
	309	if ($splice_length < 0) { $splice_length += ($length - $offset); }
	310
	311	##
	312	# Setup array with new elements, and copy out old elements for return
	313	##
	314	my @new_elements = @_;
	315	my $new_size = scalar @new_elements;
	316
df3c5701	317	my @old_elements = map {
	318	$self->FETCH( $_ )
	319	} $offset .. ($offset + $splice_length - 1);
6fe26b29	320
	321	##
	322	# Adjust array length, and shift elements to accomodate new section.
	323	##
	324	if ( $new_size != $splice_length ) {
	325	if ($new_size > $splice_length) {
	326	for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
	327	$self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
	328	}
	329	}
	330	else {
	331	for (my $i = $offset + $splice_length; $i < $length; $i++) {
	332	$self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
	333	}
	334	for (my $i = 0; $i < $splice_length - $new_size; $i++) {
	335	$self->DELETE( $length - 1 );
	336	$length--;
	337	}
	338	}
	339	}
	340
	341	##
	342	# Insert new elements into array
	343	##
	344	for (my $i = $offset; $i < $offset + $new_size; $i++) {
	345	$self->STORE( $i, shift @new_elements );
	346	}
	347
9281d66b	348	$self->unlock;
9281d66b	349
6fe26b29	350	##
	351	# Return deleted section, or last element in scalar context.
	352	##
	353	return wantarray ? @old_elements : $old_elements[-1];
	354	}
	355
460b1067	356	# We don't need to define it, yet.
460b1067	357	# It will be useful, though, when we split out HASH and ARRAY
685e40f1	358	sub EXTEND {
6fe26b29	359	##
6fe26b29	360	# Perl will call EXTEND() when the array is likely to grow.
460b1067	361	# We don't care, but include it because it gets called at times.
6fe26b29	362	##
685e40f1	363	}
6fe26b29	364
f9c33187	365	sub _copy_node {
898fd1fd	366	my $self = shift;
f9c33187	367	my ($db_temp) = @_;
	368
	369	my $length = $self->length();
	370	for (my $index = 0; $index < $length; $index++) {
	371	my $value = $self->get($index);
	372	$self->_copy_value( \$db_temp->[$index], $value );
	373	}
	374
	375	return 1;
	376	}
	377
6fe26b29	378	##
	379	# Public method aliases
	380	##
f9c33187	381	sub length { (shift)->FETCHSIZE(@_) }
	382	sub pop { (shift)->POP(@_) }
	383	sub push { (shift)->PUSH(@_) }
	384	sub unshift { (shift)->UNSHIFT(@_) }
	385	sub splice { (shift)->SPLICE(@_) }
	386
	387	# This must be last otherwise we have to qualify all other calls to shift
	388	# as calls to CORE::shift
f75b719e	389	sub shift { (CORE::shift)->SHIFT(@_) }
6fe26b29	390
	391	1;
	392	__END__