[dbsrgits/DBM-Deep.git] / t / 04_array.t

##
# DBM::Deep Test
##
use strict;
use Test::More tests => 107;
use Test::Exception;
use File::Temp qw( tempfile tempdir );
use Fcntl qw( :flock );

use_ok( 'DBM::Deep' );

my $dir = tempdir( CLEANUP => 1 );
my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
flock $fh, LOCK_UN;
my $db = DBM::Deep->new(
	file => $filename,
	type => DBM::Deep->TYPE_ARRAY
);

TODO: {
    local $TODO = "How is this test ever supposed to pass?";
    ok( !$db->clear, "If the file has never been written to, clear() returns false" );
}

##
# basic put/get/push
##
$db->[0] = "elem1";
$db->push( "elem2" );
$db->put(2, "elem3");
$db->store(3, "elem4");
$db->unshift("elem0");

is( $db->[0], 'elem0', "Array get for shift works" );
is( $db->[1], 'elem1', "Array get for array set works" );
is( $db->[2], 'elem2', "Array get for push() works" );
is( $db->[3], 'elem3', "Array get for put() works" );
is( $db->[4], 'elem4', "Array get for store() works" );

is( $db->get(0), 'elem0', "get() for shift() works" );
is( $db->get(1), 'elem1', "get() for array set works" );
is( $db->get(2), 'elem2', "get() for push() works" );
is( $db->get(3), 'elem3', "get() for put() works" );
is( $db->get(4), 'elem4', "get() for store() works" );

is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
is( $db->fetch(1), 'elem1', "fetch() for array set works" );
is( $db->fetch(2), 'elem2', "fetch() for push() works" );
is( $db->fetch(3), 'elem3', "fetch() for put() works" );
is( $db->fetch(4), 'elem4', "fetch() for store() works" );

is( $db->length, 5, "... and we have five elements" );

is( $db->[-1], $db->[4], "-1st index is 4th index" );
is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
is( $db->[-4], $db->[1], "-4th index is 1st index" );
is( $db->[-5], $db->[0], "-5th index is 0th index" );

# This is for Perls older than 5.8.0 because of is()'s prototype
{ my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }

is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );

$db->[-1] = 'elem4.1';
is( $db->[-1], 'elem4.1' );
is( $db->[4], 'elem4.1' );
is( $db->get(4), 'elem4.1' );
is( $db->fetch(4), 'elem4.1' );

throws_ok {
    $db->[-6] = 'whoops!';
} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown"; 

my $popped = $db->pop;
is( $db->length, 4, "... and we have four after popping" );
is( $db->[0], 'elem0', "0th element still there after popping" );
is( $db->[1], 'elem1', "1st element still there after popping" );
is( $db->[2], 'elem2', "2nd element still there after popping" );
is( $db->[3], 'elem3', "3rd element still there after popping" );
is( $popped, 'elem4.1', "Popped value is correct" );

my $shifted = $db->shift;
is( $db->length, 3, "... and we have three after shifting" );
is( $db->[0], 'elem1', "0th element still there after shifting" );
is( $db->[1], 'elem2', "1st element still there after shifting" );
is( $db->[2], 'elem3', "2nd element still there after shifting" );
is( $shifted, 'elem0', "Shifted value is correct" );

##
# delete
##
my $deleted = $db->delete(0);
is( $db->length, 3, "... and we still have three after deleting" );
is( $db->[0], undef, "0th element now undef" );
is( $db->[1], 'elem2', "1st element still there after deleting" );
is( $db->[2], 'elem3', "2nd element still there after deleting" );
is( $deleted, 'elem1', "Deleted value is correct" );

is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );

is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );

is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );

is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );

$deleted = $db->delete(-2);
is( $db->length, 3, "... and we still have three after deleting" );
is( $db->[0], undef, "0th element still undef" );
is( $db->[1], undef, "1st element now undef" );
is( $db->[2], 'elem3', "2nd element still there after deleting" );
is( $deleted, 'elem2', "Deleted value is correct" );

$db->[1] = 'elem2';

##
# exists
##
ok( $db->exists(1), "The 1st value exists" );
ok( !$db->exists(0), "The 0th value doesn't exists" );
ok( !$db->exists(22), "The 22nd value doesn't exists" );
ok( $db->exists(-1), "The -1st value does exists" );
ok( !$db->exists(-22), "The -22nd value doesn't exists" );

##
# clear
##
ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
is( $db->length(), 0, "After clear(), no more elements" );

is( $db->pop, undef, "pop on an empty array returns undef" );
is( $db->length(), 0, "After pop() on empty array, length is still 0" );

is( $db->shift, undef, "shift on an empty array returns undef" );
is( $db->length(), 0, "After shift() on empty array, length is still 0" );

is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );

is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );

$db->clear;

##
# multi-push
##
$db->push( 'elem first', "elem middle", "elem last" );
is( $db->length, 3, "3-element push results in three elements" );
is($db->[0], "elem first", "First element is 'elem first'");
is($db->[1], "elem middle", "Second element is 'elem middle'");
is($db->[2], "elem last", "Third element is 'elem last'");

##
# splice with length 1
##
my @returned = $db->splice( 1, 1, "middle A", "middle B" );
is( scalar(@returned), 1, "One element was removed" );
is( $returned[0], 'elem middle', "... and it was correctly removed" );
is($db->length(), 4);
is($db->[0], "elem first");
is($db->[1], "middle A");
is($db->[2], "middle B");
is($db->[3], "elem last");

##
# splice with length of 0
##
@returned = $db->splice( -1, 0, "middle C" );
is( scalar(@returned), 0, "No elements were removed" );
is($db->length(), 5);
is($db->[0], "elem first");
is($db->[1], "middle A");
is($db->[2], "middle B");
is($db->[3], "middle C");
is($db->[4], "elem last");

##
# splice with length of 3
##
my $returned = $db->splice( 1, 3, "middle ABC" );
is( $returned, 'middle C', "Just the last element was returned" );
is($db->length(), 3);
is($db->[0], "elem first");
is($db->[1], "middle ABC");
is($db->[2], "elem last");

@returned = $db->splice( 1 );
is($db->length(), 1);
is($db->[0], "elem first");
is($returned[0], "middle ABC");
is($returned[1], "elem last");

$db->push( @returned );

@returned = $db->splice( 1, -1 );
is($db->length(), 2);
is($db->[0], "elem first");
is($db->[1], "elem last");
is($returned[0], "middle ABC");

$db->[0] = [ 1 .. 3 ];
$db->[1] = { a => 'foo' };
is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
is( $db->[0]->length, 3, "Reuse of same space with array successful" );
Commit	Line	Data
ffed8b01	1	##
	2	# DBM::Deep Test
	3	##
	4	use strict;
53fdf3d7	5	use Test::More tests => 107;
ffed8b01	6	use Test::Exception;
2a81bf9e	7	use File::Temp qw( tempfile tempdir );
58910373	8	use Fcntl qw( :flock );
ffed8b01	9
	10	use_ok( 'DBM::Deep' );
	11
2a81bf9e	12	my $dir = tempdir( CLEANUP => 1 );
2a81bf9e	13	my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
58910373	14	flock $fh, LOCK_UN;
ffed8b01	15	my $db = DBM::Deep->new(
2a81bf9e	16	file => $filename,
ffed8b01	17	type => DBM::Deep->TYPE_ARRAY
ffed8b01	18	);
ffed8b01	19
	20	TODO: {
	21	local $TODO = "How is this test ever supposed to pass?";
	22	ok( !$db->clear, "If the file has never been written to, clear() returns false" );
	23	}
	24
	25	##
	26	# basic put/get/push
	27	##
	28	$db->[0] = "elem1";
	29	$db->push( "elem2" );
	30	$db->put(2, "elem3");
	31	$db->store(3, "elem4");
	32	$db->unshift("elem0");
	33
	34	is( $db->[0], 'elem0', "Array get for shift works" );
	35	is( $db->[1], 'elem1', "Array get for array set works" );
	36	is( $db->[2], 'elem2', "Array get for push() works" );
	37	is( $db->[3], 'elem3', "Array get for put() works" );
	38	is( $db->[4], 'elem4', "Array get for store() works" );
	39
	40	is( $db->get(0), 'elem0', "get() for shift() works" );
	41	is( $db->get(1), 'elem1', "get() for array set works" );
	42	is( $db->get(2), 'elem2', "get() for push() works" );
	43	is( $db->get(3), 'elem3', "get() for put() works" );
	44	is( $db->get(4), 'elem4', "get() for store() works" );
	45
	46	is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
	47	is( $db->fetch(1), 'elem1', "fetch() for array set works" );
	48	is( $db->fetch(2), 'elem2', "fetch() for push() works" );
	49	is( $db->fetch(3), 'elem3', "fetch() for put() works" );
	50	is( $db->fetch(4), 'elem4', "fetch() for store() works" );
	51
	52	is( $db->length, 5, "... and we have five elements" );
	53
7f441181	54	is( $db->[-1], $db->[4], "-1st index is 4th index" );
	55	is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
	56	is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
	57	is( $db->[-4], $db->[1], "-4th index is 1st index" );
	58	is( $db->[-5], $db->[0], "-5th index is 0th index" );
c9cec40e	59
	60	# This is for Perls older than 5.8.0 because of is()'s prototype
	61	{ my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }
	62
ffed8b01	63	is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );
ffed8b01	64
cb79ec85	65	$db->[-1] = 'elem4.1';
	66	is( $db->[-1], 'elem4.1' );
	67	is( $db->[4], 'elem4.1' );
	68	is( $db->get(4), 'elem4.1' );
	69	is( $db->fetch(4), 'elem4.1' );
	70
baa27ab6	71	throws_ok {
	72	$db->[-6] = 'whoops!';
	73	} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
	74
ffed8b01	75	my $popped = $db->pop;
	76	is( $db->length, 4, "... and we have four after popping" );
	77	is( $db->[0], 'elem0', "0th element still there after popping" );
	78	is( $db->[1], 'elem1', "1st element still there after popping" );
	79	is( $db->[2], 'elem2', "2nd element still there after popping" );
	80	is( $db->[3], 'elem3', "3rd element still there after popping" );
cb79ec85	81	is( $popped, 'elem4.1', "Popped value is correct" );
ffed8b01	82
	83	my $shifted = $db->shift;
	84	is( $db->length, 3, "... and we have three after shifting" );
	85	is( $db->[0], 'elem1', "0th element still there after shifting" );
	86	is( $db->[1], 'elem2', "1st element still there after shifting" );
	87	is( $db->[2], 'elem3', "2nd element still there after shifting" );
	88	is( $shifted, 'elem0', "Shifted value is correct" );
	89
	90	##
	91	# delete
	92	##
	93	my $deleted = $db->delete(0);
	94	is( $db->length, 3, "... and we still have three after deleting" );
	95	is( $db->[0], undef, "0th element now undef" );
	96	is( $db->[1], 'elem2', "1st element still there after deleting" );
	97	is( $db->[2], 'elem3', "2nd element still there after deleting" );
81d3d316	98	is( $deleted, 'elem1', "Deleted value is correct" );
ffed8b01	99
	100	is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
	101	is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );
	102
	103	is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
	104	is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );
	105
	106	is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
	107	is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
	108
	109	is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
	110	is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
	111
	112	$deleted = $db->delete(-2);
	113	is( $db->length, 3, "... and we still have three after deleting" );
	114	is( $db->[0], undef, "0th element still undef" );
9281d66b	115	is( $db->[1], undef, "1st element now undef" );
ffed8b01	116	is( $db->[2], 'elem3', "2nd element still there after deleting" );
9281d66b	117	is( $deleted, 'elem2', "Deleted value is correct" );
ffed8b01	118
	119	$db->[1] = 'elem2';
	120
	121	##
	122	# exists
	123	##
	124	ok( $db->exists(1), "The 1st value exists" );
	125	ok( !$db->exists(0), "The 0th value doesn't exists" );
	126	ok( !$db->exists(22), "The 22nd value doesn't exists" );
baa27ab6	127	ok( $db->exists(-1), "The -1st value does exists" );
ffed8b01	128	ok( !$db->exists(-22), "The -22nd value doesn't exists" );
	129
	130	##
	131	# clear
	132	##
	133	ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
	134	is( $db->length(), 0, "After clear(), no more elements" );
	135
	136	is( $db->pop, undef, "pop on an empty array returns undef" );
	137	is( $db->length(), 0, "After pop() on empty array, length is still 0" );
	138
	139	is( $db->shift, undef, "shift on an empty array returns undef" );
	140	is( $db->length(), 0, "After shift() on empty array, length is still 0" );
	141
8f6d6ed0	142	is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
	143	is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
	144	is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );
	145
ffed8b01	146	is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );
	147
	148	$db->clear;
	149
	150	##
	151	# multi-push
	152	##
	153	$db->push( 'elem first', "elem middle", "elem last" );
	154	is( $db->length, 3, "3-element push results in three elements" );
	155	is($db->[0], "elem first", "First element is 'elem first'");
	156	is($db->[1], "elem middle", "Second element is 'elem middle'");
	157	is($db->[2], "elem last", "Third element is 'elem last'");
	158
	159	##
	160	# splice with length 1
	161	##
8fec41b9	162	my @returned = $db->splice( 1, 1, "middle A", "middle B" );
	163	is( scalar(@returned), 1, "One element was removed" );
	164	is( $returned[0], 'elem middle', "... and it was correctly removed" );
ffed8b01	165	is($db->length(), 4);
	166	is($db->[0], "elem first");
	167	is($db->[1], "middle A");
	168	is($db->[2], "middle B");
	169	is($db->[3], "elem last");
	170
	171	##
	172	# splice with length of 0
	173	##
8fec41b9	174	@returned = $db->splice( -1, 0, "middle C" );
8fec41b9	175	is( scalar(@returned), 0, "No elements were removed" );
ffed8b01	176	is($db->length(), 5);
	177	is($db->[0], "elem first");
	178	is($db->[1], "middle A");
	179	is($db->[2], "middle B");
	180	is($db->[3], "middle C");
	181	is($db->[4], "elem last");
	182
	183	##
	184	# splice with length of 3
	185	##
8fec41b9	186	my $returned = $db->splice( 1, 3, "middle ABC" );
8fec41b9	187	is( $returned, 'middle C', "Just the last element was returned" );
ffed8b01	188	is($db->length(), 3);
	189	is($db->[0], "elem first");
	190	is($db->[1], "middle ABC");
	191	is($db->[2], "elem last");
	192
53fdf3d7	193	@returned = $db->splice( 1 );
	194	is($db->length(), 1);
	195	is($db->[0], "elem first");
	196	is($returned[0], "middle ABC");
	197	is($returned[1], "elem last");
	198
	199	$db->push( @returned );
	200
	201	@returned = $db->splice( 1, -1 );
	202	is($db->length(), 2);
	203	is($db->[0], "elem first");
	204	is($db->[1], "elem last");
	205	is($returned[0], "middle ABC");
	206
ffed8b01	207	$db->[0] = [ 1 .. 3 ];
ffed8b01	208	$db->[1] = { a => 'foo' };
ffed8b01	209	is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
994ccd8e	210	is( $db->[0]->length, 3, "Reuse of same space with array successful" );