[p5sagit/p5-mst-13.2.git] / t / lib / db-btree.t

#!./perl

BEGIN {
    @INC = '../lib';
    require Config; import Config;
    if ($Config{'extensions'} !~ /\bDB_File\b/) {
	print "1..0\n";
	exit 0;
    }
}

use DB_File; 
use Fcntl;

print "1..86\n";

$Dfile = "dbbtree.tmp";
unlink $Dfile;

umask(0);

# Check the interface to BTREEINFO

#$dbh = TIEHASH DB_File::BTREEINFO ;
$dbh = new DB_File::BTREEINFO ;
print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ;
print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ;
print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ;
print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ;
print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ;

$dbh->{flags} = 3000 ;
print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ;

$dbh->{cachesize} = 9000 ;
print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ;
#
$dbh->{psize} = 400 ;
print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ;

$dbh->{lorder} = 65 ;
print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ;

$dbh->{minkeypage} = 123 ;
print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ;

$dbh->{maxkeypage} = 1234 ;
print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ;

$dbh->{compare} = 1234 ;
print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ;

$dbh->{prefix} = 1234 ;
print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;

# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
print ($@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ? "ok 17\n" : "not ok 17\n") ;
eval '$q = $dbh->{fred}' ;
print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "ok 18\n" : "not ok 18\n") ;

# Now check the interface to BTREE

print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");

($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
   $blksize,$blocks) = stat($Dfile);
print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n");

while (($key,$value) = each(%h)) {
    $i++;
}
print (!$i ? "ok 21\n" : "not ok 21\n");

$h{'goner1'} = 'snork';

$h{'abc'} = 'ABC';
print ($h{'abc'} eq 'ABC' ? "ok 22\n" : "not ok 22\n") ;
print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");

$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
$h{'a'} = 'A';

#$h{'b'} = 'B';
$X->STORE('b', 'B') ;

$h{'c'} = 'C';

#$h{'d'} = 'D';
$X->put('d', 'D') ;

$h{'e'} = 'E';
$h{'f'} = 'F';
$h{'g'} = 'X';
$h{'h'} = 'H';
$h{'i'} = 'I';

$h{'goner2'} = 'snork';
delete $h{'goner2'};


# IMPORTANT - $X must be undefined before the untie otherwise the
#             underlying DB close routine will not get called.
undef $X ;
untie(%h);


# tie to the same file again
print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n");

# Modify an entry from the previous tie
$h{'g'} = 'G';

$h{'j'} = 'J';
$h{'k'} = 'K';
$h{'l'} = 'L';
$h{'m'} = 'M';
$h{'n'} = 'N';
$h{'o'} = 'O';
$h{'p'} = 'P';
$h{'q'} = 'Q';
$h{'r'} = 'R';
$h{'s'} = 'S';
$h{'t'} = 'T';
$h{'u'} = 'U';
$h{'v'} = 'V';
$h{'w'} = 'W';
$h{'x'} = 'X';
$h{'y'} = 'Y';
$h{'z'} = 'Z';

$h{'goner3'} = 'snork';

delete $h{'goner1'};
$X->DELETE('goner3');

@keys = keys(%h);
@values = values(%h);

if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";}

while (($key,$value) = each(%h)) {
    if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
	$key =~ y/a-z/A-Z/;
	$i++ if $key eq $value;
    }
}

if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}

@keys = ('blurfl', keys(%h), 'dyick');
if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}

#Check that the keys can be retrieved in order
$ok = 1 ;
foreach (keys %h)
{
    ($ok = 0), last if defined $previous && $previous gt $_ ;
    $previous = $_ ;
}
print ($ok ? "ok 28\n" : "not ok 28\n") ;

$h{'foo'} = '';
print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ;

$h{''} = 'bar';
print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ;

# check cache overflow and numeric keys and contents
$ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
print ($ok ? "ok 31\n" : "not ok 31\n");

($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
   $blksize,$blocks) = stat($Dfile);
print ($size > 0 ? "ok 32\n" : "not ok 32\n");

@h{0..200} = 200..400;
@foo = @h{0..200};
print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";

# Now check all the non-tie specific stuff


# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
# an existing record.
 
$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
print ($status == 1 ? "ok 34\n" : "not ok 34\n") ;
 
# check that the value of the key 'x' has not been changed by the 
# previous test
print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ;

# standard put
$status = $X->put('key', 'value') ;
print ($status == 0 ? "ok 36\n" : "not ok 36\n") ;

#check that previous put can be retrieved
$status = $X->get('key', $value) ;
print ($status == 0 ? "ok 37\n" : "not ok 37\n") ;
print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ;

# Attempting to delete an existing key should work

$status = $X->del('q') ;
print ($status == 0 ? "ok 39\n" : "not ok 39\n") ;
$status = $X->del('') ;
print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;

# Make sure that the key deleted, cannot be retrieved
print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ;
print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ;

undef $X ;
untie %h ;

print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43");

# Attempting to delete a non-existant key should fail

$status = $X->del('joe') ;
print ($status == 1 ? "ok 44\n" : "not ok 44\n") ;

# Check the get interface

# First a non-existing key
$status = $X->get('aaaa', $value) ;
print ($status == 1 ? "ok 45\n" : "not ok 45\n") ;

# Next an existing key
$status = $X->get('a', $value) ;
print ($status == 0 ? "ok 46\n" : "not ok 46\n") ;
print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;

# seq
# ###

# use seq to find an approximate match
$key = 'ke' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
print ($status == 0 ? "ok 48\n" : "not ok 48\n") ;
print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ;
print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ;

# seq when the key does not match
$key = 'zzz' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;


# use seq to set the cursor, then delete the record @ the cursor.

$key = 'x' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
print ($status == 0 ? "ok 52\n" : "not ok 52\n") ;
print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ;
print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ;
$status = $X->del(0, R_CURSOR) ;
print ($status == 0 ? "ok 55\n" : "not ok 55\n") ;
$status = $X->get('x', $value) ;
print ($status == 1 ? "ok 56\n" : "not ok 56\n") ;

# ditto, but use put to replace the key/value pair.
$key = 'y' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
print ($status == 0 ? "ok 57\n" : "not ok 57\n") ;
print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ;
print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ;

$key = "replace key" ;
$value = "replace value" ;
$status = $X->put($key, $value, R_CURSOR) ;
print ($status == 0 ? "ok 60\n" : "not ok 60\n") ;
print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ;
print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ;
$status = $X->get('y', $value) ;
print ($status == 1 ? "ok 63\n" : "not ok 63\n") ;

# use seq to walk forwards through a file 

$status = $X->seq($key, $value, R_FIRST) ;
print ($status == 0 ? "ok 64\n" : "not ok 64\n") ;
$previous = $key ;

$ok = 1 ;
while (($status = $X->seq($key, $value, R_NEXT)) == 0)
{
    ($ok = 0), last if ($previous cmp $key) == 1 ;
}

print ($status == 1 ? "ok 65\n" : "not ok 65\n") ;
print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ;

# use seq to walk backwards through a file 
$status = $X->seq($key, $value, R_LAST) ;
print ($status == 0 ? "ok 67\n" : "not ok 67\n") ;
$previous = $key ;

$ok = 1 ;
while (($status = $X->seq($key, $value, R_PREV)) == 0)
{
    ($ok = 0), last if ($previous cmp $key) == -1 ;
    #print "key = [$key] value = [$value]\n" ;
}

print ($status == 1 ? "ok 68\n" : "not ok 68\n") ;
print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;


# check seq FIRST/LAST

# sync
# ####

$status = $X->sync ;
print ($status == 0 ? "ok 70\n" : "not ok 70\n") ;


# fd
# ##

$status = $X->fd ;
print ($status != 0 ? "ok 71\n" : "not ok 71\n") ;


undef $X ;
untie %h ;

unlink $Dfile;

# Now try an in memory file
print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72");

# fd with an in memory file should return failure
$status = $Y->fd ;
print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;


undef $Y ;
untie %h ;

# Duplicate keys
my $bt = new DB_File::BTREEINFO ;
$bt->{flags} = R_DUP ;
print (($YY = tie(%hh, DB_File, $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ? "ok 74\n" : "not ok 74");

$hh{'Wall'} = 'Larry' ;
$hh{'Wall'} = 'Stone' ; # Note the duplicate key
$hh{'Wall'} = 'Brick' ; # Note the duplicate key
$hh{'Smith'} = 'John' ;
$hh{'mouse'} = 'mickey' ;

# first work in scalar context
print(scalar $YY->get_dup('Unknown') == 0 ? "ok 75\n" : "not ok 75\n") ;
print(scalar $YY->get_dup('Smith') == 1 ? "ok 76\n" : "not ok 76\n") ;
print(scalar $YY->get_dup('Wall') == 3 ? "ok 77\n" : "not ok 77\n") ;

# now in list context
my @unknown = $YY->get_dup('Unknown') ;
print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;

my @smith = $YY->get_dup('Smith') ;
print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;

my @wall = $YY->get_dup('Wall') ;
my %wall ;
@wall{@wall} = @wall ;
print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ;

# hash
my %unknown = $YY->get_dup('Unknown', 1) ;
print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;

my %smith = $YY->get_dup('Smith', 1) ;
print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;

my %wall = $YY->get_dup('Wall', 1) ;
print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;

undef $YY ;
untie %hh ;
unlink $Dfile;


# test multiple callbacks
$Dfile1 = "btree1" ;
$Dfile2 = "btree2" ;
$Dfile3 = "btree3" ;
 
$dbh1 = TIEHASH DB_File::BTREEINFO ;
$dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
 
$dbh2 = TIEHASH DB_File::BTREEINFO ;
$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
 
$dbh3 = TIEHASH DB_File::BTREEINFO ;
$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
 
 
tie(%h, DB_File,$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
tie(%g, DB_File,$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
tie(%k, DB_File,$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
 
@Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
@srt_1 = sort { $a <=> $b } @Keys ;
@srt_2 = sort { $a cmp $b } @Keys ;
@srt_3 = sort { length $a <=> length $b } @Keys ;
 
foreach (@Keys) {
    $h{$_} = 1 ;
    $g{$_} = 1 ;
    $k{$_} = 1 ;
}
 
sub ArrayCompare
{
    my($a, $b) = @_ ;
 
    return 0 if @$a != @$b ;
 
    foreach (1 .. length @$a)
    {
        return 0 unless $$a[$_] eq $$b[$_] ;
    }
 
    1 ;
}
 
print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 84\n" : "not ok 84\n") ;
print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 85\n" : "not ok 85\n") ;
print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 86\n" : "not ok 86\n") ;

untie %h ;
untie %g ;
untie %k ;
unlink $Dfile1, $Dfile2, $Dfile3 ;

exit ;
Commit	Line	Data
a0d0e21e	1	#!./perl
	2
	3	BEGIN {
	4	@INC = '../lib';
	5	require Config; import Config;
	6	if ($Config{'extensions'} !~ /\bDB_File\b/) {
	7	print "1..0\n";
	8	exit 0;
	9	}
	10	}
	11
	12	use DB_File;
	13	use Fcntl;
	14
55d68b4a	15	print "1..86\n";
a0d0e21e	16
55d68b4a	17	$Dfile = "dbbtree.tmp";
a0d0e21e	18	unlink $Dfile;
	19
	20	umask(0);
	21
	22	# Check the interface to BTREEINFO
	23
55d68b4a	24	#$dbh = TIEHASH DB_File::BTREEINFO ;
55d68b4a	25	$dbh = new DB_File::BTREEINFO ;
a0d0e21e	26	print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
	27	print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
	28	print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
	29	print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ;
	30	print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ;
	31	print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ;
	32	print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ;
	33	print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ;
	34
	35	$dbh->{flags} = 3000 ;
	36	print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ;
	37
	38	$dbh->{cachesize} = 9000 ;
	39	print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ;
	40	#
	41	$dbh->{psize} = 400 ;
	42	print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ;
	43
	44	$dbh->{lorder} = 65 ;
	45	print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ;
	46
	47	$dbh->{minkeypage} = 123 ;
	48	print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ;
	49
	50	$dbh->{maxkeypage} = 1234 ;
	51	print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ;
	52
	53	$dbh->{compare} = 1234 ;
	54	print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ;
	55
	56	$dbh->{prefix} = 1234 ;
	57	print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;
	58
	59	# Check that an invalid entry is caught both for store & fetch
	60	eval '$dbh->{fred} = 1234' ;
55d68b4a	61	print ($@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ? "ok 17\n" : "not ok 17\n") ;
a0d0e21e	62	eval '$q = $dbh->{fred}' ;
55d68b4a	63	print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "ok 18\n" : "not ok 18\n") ;
a0d0e21e	64
	65	# Now check the interface to BTREE
	66
	67	print (($X = tie(%h, DB_File,$Dfile, O_RDWR\|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
	68
	69	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
	70	$blksize,$blocks) = stat($Dfile);
	71	print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n");
	72
	73	while (($key,$value) = each(%h)) {
	74	$i++;
	75	}
	76	print (!$i ? "ok 21\n" : "not ok 21\n");
	77
	78	$h{'goner1'} = 'snork';
	79
	80	$h{'abc'} = 'ABC';
55d68b4a	81	print ($h{'abc'} eq 'ABC' ? "ok 22\n" : "not ok 22\n") ;
a0d0e21e	82	print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
	83
	84	$h{'def'} = 'DEF';
	85	$h{'jkl','mno'} = "JKL\034MNO";
	86	$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
	87	$h{'a'} = 'A';
	88
	89	#$h{'b'} = 'B';
	90	$X->STORE('b', 'B') ;
	91
	92	$h{'c'} = 'C';
	93
	94	#$h{'d'} = 'D';
	95	$X->put('d', 'D') ;
	96
	97	$h{'e'} = 'E';
	98	$h{'f'} = 'F';
	99	$h{'g'} = 'X';
	100	$h{'h'} = 'H';
	101	$h{'i'} = 'I';
	102
	103	$h{'goner2'} = 'snork';
	104	delete $h{'goner2'};
	105
	106
	107	# IMPORTANT - $X must be undefined before the untie otherwise the
	108	# underlying DB close routine will not get called.
	109	undef $X ;
	110	untie(%h);
	111
	112
	113	# tie to the same file again
	114	print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n");
	115
	116	# Modify an entry from the previous tie
	117	$h{'g'} = 'G';
	118
	119	$h{'j'} = 'J';
	120	$h{'k'} = 'K';
	121	$h{'l'} = 'L';
	122	$h{'m'} = 'M';
	123	$h{'n'} = 'N';
	124	$h{'o'} = 'O';
	125	$h{'p'} = 'P';
	126	$h{'q'} = 'Q';
	127	$h{'r'} = 'R';
	128	$h{'s'} = 'S';
	129	$h{'t'} = 'T';
	130	$h{'u'} = 'U';
	131	$h{'v'} = 'V';
	132	$h{'w'} = 'W';
	133	$h{'x'} = 'X';
	134	$h{'y'} = 'Y';
	135	$h{'z'} = 'Z';
	136
	137	$h{'goner3'} = 'snork';
	138
	139	delete $h{'goner1'};
	140	$X->DELETE('goner3');
	141
	142	@keys = keys(%h);
	143	@values = values(%h);
	144
	145	if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";}
146
147	while (($key,$value) = each(%h)) {
148	if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
149	$key =~ y/a-z/A-Z/;
150	$i++ if $key eq $value;
151	}
152	}
153
154	if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
155
55d68b4a	156	@keys = ('blurfl', keys(%h), 'dyick');
a0d0e21e	157	if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
	158
	159	#Check that the keys can be retrieved in order
	160	$ok = 1 ;
	161	foreach (keys %h)
	162	{
	163	($ok = 0), last if defined $previous && $previous gt $_ ;
	164	$previous = $_ ;
	165	}
	166	print ($ok ? "ok 28\n" : "not ok 28\n") ;
	167
	168	$h{'foo'} = '';
	169	print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ;
	170
	171	$h{''} = 'bar';
	172	print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ;
	173
	174	# check cache overflow and numeric keys and contents
	175	$ok = 1;
	176	for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
	177	for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
	178	print ($ok ? "ok 31\n" : "not ok 31\n");
	179
	180	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
	181	$blksize,$blocks) = stat($Dfile);
	182	print ($size > 0 ? "ok 32\n" : "not ok 32\n");
	183
	184	@h{0..200} = 200..400;
	185	@foo = @h{0..200};
	186	print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";
	187
	188	# Now check all the non-tie specific stuff
	189
	190
	191	# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
	192	# an existing record.
	193
	194	$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
	195	print ($status == 1 ? "ok 34\n" : "not ok 34\n") ;
	196
	197	# check that the value of the key 'x' has not been changed by the
	198	# previous test
	199	print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ;
	200
	201	# standard put
	202	$status = $X->put('key', 'value') ;
	203	print ($status == 0 ? "ok 36\n" : "not ok 36\n") ;
	204
	205	#check that previous put can be retrieved
	206	$status = $X->get('key', $value) ;
	207	print ($status == 0 ? "ok 37\n" : "not ok 37\n") ;
	208	print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ;
	209
	210	# Attempting to delete an existing key should work
	211
	212	$status = $X->del('q') ;
	213	print ($status == 0 ? "ok 39\n" : "not ok 39\n") ;
	214	$status = $X->del('') ;
	215	print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;
	216
	217	# Make sure that the key deleted, cannot be retrieved
	218	print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ;
	219	print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ;
	220
221	undef $X ;
222	untie %h ;
223
224	print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43");
225
226	# Attempting to delete a non-existant key should fail
227
228	$status = $X->del('joe') ;
229	print ($status == 1 ? "ok 44\n" : "not ok 44\n") ;
230
231	# Check the get interface
232
233	# First a non-existing key
234	$status = $X->get('aaaa', $value) ;
235	print ($status == 1 ? "ok 45\n" : "not ok 45\n") ;
236
237	# Next an existing key
238	$status = $X->get('a', $value) ;
239	print ($status == 0 ? "ok 46\n" : "not ok 46\n") ;
240	print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;
241
242	# seq
243	# ###
244
245	# use seq to find an approximate match
246	$key = 'ke' ;
247	$value = '' ;
248	$status = $X->seq($key, $value, R_CURSOR) ;
249	print ($status == 0 ? "ok 48\n" : "not ok 48\n") ;
250	print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ;
251	print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ;
252
253	# seq when the key does not match
254	$key = 'zzz' ;
255	$value = '' ;
256	$status = $X->seq($key, $value, R_CURSOR) ;
257	print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;
258
259
260	# use seq to set the cursor, then delete the record @ the cursor.
261
262	$key = 'x' ;
263	$value = '' ;
264	$status = $X->seq($key, $value, R_CURSOR) ;
265	print ($status == 0 ? "ok 52\n" : "not ok 52\n") ;
266	print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ;
267	print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ;
268	$status = $X->del(0, R_CURSOR) ;
269	print ($status == 0 ? "ok 55\n" : "not ok 55\n") ;
270	$status = $X->get('x', $value) ;
271	print ($status == 1 ? "ok 56\n" : "not ok 56\n") ;
272
273	# ditto, but use put to replace the key/value pair.
274	$key = 'y' ;
275	$value = '' ;
276	$status = $X->seq($key, $value, R_CURSOR) ;
277	print ($status == 0 ? "ok 57\n" : "not ok 57\n") ;
278	print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ;
279	print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ;
280
281	$key = "replace key" ;
282	$value = "replace value" ;
283	$status = $X->put($key, $value, R_CURSOR) ;
284	print ($status == 0 ? "ok 60\n" : "not ok 60\n") ;
285	print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ;
286	print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ;
287	$status = $X->get('y', $value) ;
288	print ($status == 1 ? "ok 63\n" : "not ok 63\n") ;
289
290	# use seq to walk forwards through a file
291
292	$status = $X->seq($key, $value, R_FIRST) ;
293	print ($status == 0 ? "ok 64\n" : "not ok 64\n") ;
294	$previous = $key ;
295
296	$ok = 1 ;
297	while (($status = $X->seq($key, $value, R_NEXT)) == 0)
298	{
299	($ok = 0), last if ($previous cmp $key) == 1 ;
300	}
301
302	print ($status == 1 ? "ok 65\n" : "not ok 65\n") ;
303	print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ;
304
305	# use seq to walk backwards through a file
306	$status = $X->seq($key, $value, R_LAST) ;
307	print ($status == 0 ? "ok 67\n" : "not ok 67\n") ;
308	$previous = $key ;
309
310	$ok = 1 ;
311	while (($status = $X->seq($key, $value, R_PREV)) == 0)
312	{
313	($ok = 0), last if ($previous cmp $key) == -1 ;
314	#print "key = [$key] value = [$value]\n" ;
315	}
316
317	print ($status == 1 ? "ok 68\n" : "not ok 68\n") ;
318	print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;
319
320
321	# check seq FIRST/LAST
322
323	# sync
324	# ####
325
326	$status = $X->sync ;
327	print ($status == 0 ? "ok 70\n" : "not ok 70\n") ;
328
329
330	# fd
331	# ##
332
333	$status = $X->fd ;
334	print ($status != 0 ? "ok 71\n" : "not ok 71\n") ;
335
336
337	undef $X ;
338	untie %h ;
339
340	unlink $Dfile;
341
342	# Now try an in memory file
343	print (($Y = tie(%h, DB_File,undef, O_RDWR\|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72");
344
345	# fd with an in memory file should return failure
346	$status = $Y->fd ;
347	print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
348
55d68b4a	349
a0d0e21e	350	undef $Y ;
	351	untie %h ;
	352
55d68b4a	353	# Duplicate keys
	354	my $bt = new DB_File::BTREEINFO ;
	355	$bt->{flags} = R_DUP ;
	356	print (($YY = tie(%hh, DB_File, $Dfile, O_RDWR\|O_CREAT, 0640, $bt )) ? "ok 74\n" : "not ok 74");
	357
	358	$hh{'Wall'} = 'Larry' ;
	359	$hh{'Wall'} = 'Stone' ; # Note the duplicate key
	360	$hh{'Wall'} = 'Brick' ; # Note the duplicate key
	361	$hh{'Smith'} = 'John' ;
	362	$hh{'mouse'} = 'mickey' ;
	363
	364	# first work in scalar context
	365	print(scalar $YY->get_dup('Unknown') == 0 ? "ok 75\n" : "not ok 75\n") ;
	366	print(scalar $YY->get_dup('Smith') == 1 ? "ok 76\n" : "not ok 76\n") ;
	367	print(scalar $YY->get_dup('Wall') == 3 ? "ok 77\n" : "not ok 77\n") ;
	368
	369	# now in list context
	370	my @unknown = $YY->get_dup('Unknown') ;
	371	print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;
	372
	373	my @smith = $YY->get_dup('Smith') ;
	374	print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;
	375
	376	my @wall = $YY->get_dup('Wall') ;
	377	my %wall ;
	378	@wall{@wall} = @wall ;
	379	print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ;
	380
	381	# hash
	382	my %unknown = $YY->get_dup('Unknown', 1) ;
	383	print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;
	384
	385	my %smith = $YY->get_dup('Smith', 1) ;
	386	print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;
	387
	388	my %wall = $YY->get_dup('Wall', 1) ;
	389	print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;
	390
	391	undef $YY ;
	392	untie %hh ;
	393	unlink $Dfile;
	394
	395
8e07c86e	396	# test multiple callbacks
	397	$Dfile1 = "btree1" ;
	398	$Dfile2 = "btree2" ;
	399	$Dfile3 = "btree3" ;
	400
	401	$dbh1 = TIEHASH DB_File::BTREEINFO ;
	402	$dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
	403
	404	$dbh2 = TIEHASH DB_File::BTREEINFO ;
	405	$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
	406
	407	$dbh3 = TIEHASH DB_File::BTREEINFO ;
	408	$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
	409
	410
	411	tie(%h, DB_File,$Dfile1, O_RDWR\|O_CREAT, 0640, $dbh1 ) ;
	412	tie(%g, DB_File,$Dfile2, O_RDWR\|O_CREAT, 0640, $dbh2 ) ;
	413	tie(%k, DB_File,$Dfile3, O_RDWR\|O_CREAT, 0640, $dbh3 ) ;
	414
	415	@Keys = qw( 0123 12 -1234 9 987654321 def ) ;
	416	@srt_1 = sort { $a <=> $b } @Keys ;
	417	@srt_2 = sort { $a cmp $b } @Keys ;
	418	@srt_3 = sort { length $a <=> length $b } @Keys ;
	419
	420	foreach (@Keys) {
	421	$h{$_} = 1 ;
	422	$g{$_} = 1 ;
	423	$k{$_} = 1 ;
	424	}
	425
	426	sub ArrayCompare
	427	{
	428	my($a, $b) = @_ ;
	429
	430	return 0 if @$a != @$b ;
	431
	432	foreach (1 .. length @$a)
	433	{
	434	return 0 unless $$a[$_] eq $$b[$_] ;
	435	}
	436
	437	1 ;
	438	}
	439
55d68b4a	440	print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 84\n" : "not ok 84\n") ;
	441	print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 85\n" : "not ok 85\n") ;
	442	print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 86\n" : "not ok 86\n") ;
8e07c86e	443
	444	untie %h ;
	445	untie %g ;
	446	untie %k ;
	447	unlink $Dfile1, $Dfile2, $Dfile3 ;
	448
a0d0e21e	449	exit ;