db-btree.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./perl -w
BEGIN {
print "1..0 # Skip: DB_File was not built\n";
exit 0;
}
}
use warnings;
use strict;
use DB_File;
use Fcntl;
print "1..157\n";
sub ok
{
my $no = shift ;
my $result = shift ;
}
sub lexical
{
my $i = 0 ;
return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
}
return @a - @b ;
}
{
use Symbol ;
sub new
{
my $class = shift ;
my $filename = shift ;
return bless [$fh, $real_stdout ] ;
}
sub DESTROY
{
my $self = shift ;
}
}
sub docat
{
my $file = shift;
#local $/ = undef unless wantarray ;
}
sub docat_del
{
my $file = shift;
#local $/ = undef unless wantarray ;
}
my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
my $null_keys_allowed = ($DB_File::db_ver < 2.004010
my $Dfile = "dbbtree.tmp";
umask(0);
# Check the interface to BTREEINFO
ok(5, ! defined $dbh->{minkeypage}) ;
ok(6, ! defined $dbh->{maxkeypage}) ;
ok(13, $dbh->{minkeypage} == 123) ;
ok(14, $dbh->{maxkeypage} == 1234 );
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
eval 'my $q = $dbh->{fred}' ;
# Now check the interface to BTREE
my ($X, %h) ;
$i++;
}
ok(21, !$i ) ;
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a'} = 'A';
#$h{'b'} = 'B';
$h{'c'} = 'C';
#$h{'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
# 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'};
$i = 0 ;
}
}
ok(28, $i == 30) ;
#Check that the keys can be retrieved in order
my @b = keys %h ;
$h{'foo'} = '';
# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
# This feature was reenabled in version 3.1 of Berkeley DB.
my $result = 0 ;
if ($null_keys_allowed) {
$h{''} = 'bar';
}
else
{ $result = 1 }
# check cache overflow and numeric keys and contents
my $ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
@h{0..200} = 200..400;
my @foo = @h{0..200};
# Now check all the non-tie specific stuff
# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
# an existing record.
# check that the value of the key 'x' has not been changed by the
# previous test
# standard put
#check that previous put can be retrieved
$value = 0 ;
# Attempting to delete an existing key should work
} else {
$status = 0 ;
}
# Make sure that the key deleted, cannot be retrieved
undef $X ;
untie %h ;
# Attempting to delete a non-existant key should fail
# Check the get interface
# First a non-existing key
# Next an existing key
# seq
# ###
# use seq to find an approximate match
# seq when the key does not match
# use seq to set the cursor, then delete the record @ the cursor.
# only worked because of a bug in 1.85/6
# use seq to walk forwards through a file
$ok = 1 ;
{
}
# use seq to walk backwards through a file
$ok = 1 ;
{
#print "key = [$key] value = [$value]\n" ;
}
# sync
# ####
# fd
# ##
undef $X ;
untie %h ;
# Now try an in memory file
my $Y;
# fd with an in memory file should return failure
undef $Y ;
untie %h ;
# Duplicate keys
# first work in scalar context
# now in list context
{
my %wall ;
}
# hash
# test multiple callbacks
$_[0] <=> $_[1] } ;
my (%g, %k);
{
}
$h{$_} = 1 ;
$g{$_} = 1 ;
$k{$_} = 1 ;
}
sub ArrayCompare
{
my($a, $b) = @_ ;
return 0 if @$a != @$b ;
foreach (1 .. length @$a)
{
}
1 ;
}
untie %h ;
untie %g ;
untie %k ;
# clear
# #####
foreach (1 .. 10)
{ $h{$_} = $_ * 100 }
# check that there are 10 elements in the hash
$i = 0 ;
$i++;
}
# now clear the hash
%h = () ;
# check it is empty
$i = 0 ;
$i++;
}
untie %h ;
{
# check that attempting to tie an array to a DB_BTREE will fail
my @x ;
}
{
# sub-class test
use warnings ;
use strict ;
use warnings ;
use strict ;
require Exporter ;
use DB_File;
sub STORE {
my $self = shift ;
my $key = shift ;
my $value = shift ;
}
sub FETCH {
my $self = shift ;
my $key = shift ;
}
sub put {
my $self = shift ;
my $key = shift ;
my $value = shift ;
}
sub get {
my $self = shift ;
$_[1] -= 2 ;
}
sub A_new_method
{
my $self = shift ;
my $key = shift ;
}
1 ;
eval 'use SubDB ; ';
my %h ;
my $X ;
eval '
$X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
' ;
my $value = 0;
undef $X;
}
{
# DBM Filter tests
use warnings ;
use strict ;
sub checkOutput
{
return
$fetch_key eq $fk && $store_key eq $sk &&
$fetch_value eq $fv && $store_value eq $sv &&
}
$_ = "original" ;
$h{"fred"} = "joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# replace the filters, but remember the previous set
$h{"Fred"} = "Joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# put the original filters back
$h{"fred"} = "joe" ;
# delete the filters
$h{"fred"} = "joe" ;
untie %h;
}
{
# DBM Filter with a closure
use warnings ;
use strict ;
sub Closure
{
my $count = 0 ;
return sub { ++$count ;
}
}
$_ = "original" ;
$h{"fred"} = "joe" ;
$h{"jim"} = "john" ;
untie %h;
}
{
# DBM Filter recursion detection
use warnings ;
use strict ;
eval '$h{1} = 1234' ;
untie %h;
}
{
# Examples from the POD
{
# BTREE example 1
###
use strict ;
use DB_File ;
my %h ;
sub Compare
{
}
# specify the Perl sub that will do the comparison
$h{'Wall'} = 'Larry' ;
$h{'Smith'} = 'John' ;
$h{'mouse'} = 'mickey' ;
$h{'duck'} = 'donald' ;
# Delete
# Cycle through the keys printing them in order.
# Note it is not necessary to sort the keys as
# the btree will have kept them in order automatically.
foreach (keys %h)
{ print "$_\n" }
untie %h ;
}
{
# BTREE example 2
###
use strict ;
use DB_File ;
# Enable duplicate records
$h{'Wall'} = 'Larry' ;
$h{'Wall'} = 'Brick' ; # Note the duplicate key
$h{'Wall'} = 'Brick' ; # Note the duplicate key and value
$h{'Smith'} = 'John' ;
$h{'mouse'} = 'mickey' ;
# iterate through the associative array
foreach (keys %h)
{ print "$_ -> $h{$_}\n" }
untie %h ;
}
{
# BTREE example 3
###
use strict ;
use DB_File ;
# Enable duplicate records
$h{'Wall'} = 'Larry' ;
$h{'Wall'} = 'Brick' ; # Note the duplicate key
$h{'Wall'} = 'Brick' ; # Note the duplicate key and value
$h{'Smith'} = 'John' ;
$h{'mouse'} = 'mickey' ;
# iterate through the btree using seq
$status == 0 ;
undef $x ;
untie %h ;
}
{
# BTREE example 4
###
use strict ;
use DB_File ;
# Enable duplicate records
print "Wall => [@list]\n" ;
print "Smith => [@list]\n" ;
print "Dog => [@list]\n" ;
undef $x ;
untie %h ;
}
Dog => []
{
# BTREE example 5
###
use strict ;
use DB_File ;
# Enable duplicate records
undef $x ;
untie %h ;
}
{
# BTREE example 6
###
use strict ;
use DB_File ;
# Enable duplicate records
undef $x ;
untie %h ;
}
{
# BTREE example 7
###
use strict ;
use DB_File ;
use Fcntl ;
sub match
{
my $key = shift ;
my $value = 0;
}
$h{'mouse'} = 'mickey' ;
$h{'Wall'} = 'Larry' ;
$h{'Walls'} = 'Brick' ;
$h{'Smith'} = 'John' ;
print "IN ORDER\n" ;
$st == 0 ;
print "\nPARTIAL MATCH\n" ;
undef $x ;
untie %h ;
}
}
#{
# # R_SETCURSOR
# use strict ;
# my (%h, $db) ;
# unlink $Dfile;
#
# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
#
# $h{abc} = 33 ;
# my $k = "newest" ;
# my $v = 44 ;
# my $status = $db->put($k, $v, R_SETCURSOR) ;
# print "status = [$status]\n" ;
# ok(157, $status == 0) ;
# $status = $db->del($k, R_CURSOR) ;
# print "status = [$status]\n" ;
# ok(158, $status == 0) ;
# $k = "newest" ;
# ok(159, $db->get($k, $v, R_CURSOR)) ;
#
# ok(160, keys %h == 1) ;
#
# undef $db ;
# untie %h;
# unlink $Dfile;
#}
{
# Bug ID 20001013.009
#
# test that $hash{KEY} = undef doesn't produce the warning
# Use of uninitialized value in null operation
use warnings ;
use strict ;
use DB_File ;
my %h ;
my $a = "";
untie %h ;
}
{
# test that %hash = () doesn't produce the warning
# Argument "" isn't numeric in entersub
use warnings ;
use strict ;
use DB_File ;
my %h ;
my $a = "";
%h = (); ;
untie %h ;
}
exit ;