BerkeleyDB
view release on metacpan or search on metacpan
ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
or diag "Status is [" . $db->status() . "]";
ok $db->db_sync() == 0 ;
# Check NOOVERWRITE will make put fail when attempting to overwrite
# an existing record.
ok $db->db_put( $key2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
ok $db->status() =~ $DB_errors{'DB_KEYEXIST'} ;
ok $db->status() == DB_KEYEXIST ;
# check that the value of the key has not been changed by the
# previous test
ok $db->db_get($key2, $value) == 0 ;
ok $value eq "value" ;
# test DB_GET_BOTH
my ($k, $v) = ($key2, "value") ;
ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
($k, $v) = ($key2, "fred") ;
ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
($k, $v) = ("another", "value") ;
ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
}
{
# Check simple env works with a hash.
my $lex = new LexFile $Dfile ;
my $home = "./fred" ;
ok my $lexD = new LexDir($home) ;
ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
@StdErrFile, -Home => $home ;
ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
-Env => $env,
-Flags => DB_CREATE ;
isa_ok $db->Env, 'BerkeleyDB::Env';
$db->Env->errPrefix("abc");
is $db->Env->errPrefix("abc"), 'abc';
# Add a k/v pair
my $key ;
my $value ;
ok $db->db_put($key, "some value", DB_APPEND) == 0 ;
ok $db->db_get($key, $value) == 0 ;
ok $value eq "some value" ;
undef $db ;
undef $env ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my %hash ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
-Flags => DB_CREATE ;
#print "[$db] [$!] $BerkeleyDB::Error\n" ;
# create some data
my %data = ();
my %keys = ();
my $ret = 0 ;
for my $v (qw(2 house sea)){
my $key;
$ret += $db->db_put($key, $v, DB_APPEND) ;
$data{$key} = $v;
$keys{$v} = $key;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = $v = "" ;
my %copy = %data ;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'};
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'};
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0, "extras == 0" ;
($k, $v) = ($keys{"house"}, "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0, "c_get BOTH" ;
($k, $v) = ($keys{"house"}, "door") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
($k, $v) = ("black", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
}
{
# in-memory file
my $lex = new LexFile $Dfile ;
my %hash ;
my $fd ;
my $value ;
#ok my $db = tie %hash, 'BerkeleyDB::Heap' ;
my $db = new BerkeleyDB::Heap
-Flags => DB_CREATE ;
isa_ok $db, 'BerkeleyDB::Heap' ;
my $key;
ok $db->db_put($key, "some value", DB_APPEND) == 0 ;
ok $db->db_get($key, $value) == 0 ;
ok $value eq "some value", "some value" ;
}
if (0)
{
# partial
# check works via API
my $lex = new LexFile $Dfile ;
my $value ;
ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
-Flags => DB_CREATE ;
# create some data
my $red;
my $green;
my $blue;
my %data = (
"red" => "boat",
"green" => "house",
"blue" => "sea",
) ;
my %keys = (
"red" => \$red,
"green" => \$green,
"blue" => \$blue,
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
my $key;
$ret += $db->db_put($key, $v, DB_APPEND) ;
${ $keys{$k} } = $key;
}
ok $ret == 0, "ret 0" ;
ok $db->db_get($green, $value) == 0 && $value eq "ABuse" ;
ok $db->db_get($blue, $value) == 0 && $value eq "XYZa" ;
ok $db->db_get($new, $value) == 0 && $value eq "KLM" ;
# now partial put
($pon, $off, $len) = $db->partial_set(3,2) ;
ok ! $pon ;
ok $off == 0 ;
ok $len == 0 ;
ok $db->db_put($red, "PPP") == 0 ;
ok $db->db_put($green, "Q") == 0, "Q" ;
ok $db->db_put($blue, "XYZ") == 0, "XYZ" ; # <<<<<<<<<<<<<<
ok $db->db_put($new, "TU") == 0 ;
$db->partial_clear() ;
ok $db->db_get($red, $value) == 0 && $value eq "at\0PPP" ;
ok $db->db_get($green, $value) == 0 && $value eq "ABuQ" ;
ok $db->db_get($blue, $value) == 0 && $value eq "XYZXYZ" ;
ok $db->db_get($new, $value) == 0 && $value eq "KLMTU", "KLMTU" ;
}
{
# transaction
my $lex = new LexFile $Dfile ;
my %hash ;
my $value ;
my $home = "./fred" ;
ok my $lexD = new LexDir($home) ;
ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
-Flags => DB_CREATE|DB_INIT_TXN|
DB_INIT_MPOOL|DB_INIT_LOCK ;
ok my $txn = $env->txn_begin() ;
ok my $db1 = new BerkeleyDB::Heap -Filename => $Dfile,
-Flags => DB_CREATE ,
-Env => $env,
-Txn => $txn ;
ok ((my $Z = $txn->txn_commit()) == 0) ;
ok $txn = $env->txn_begin() ;
$db1->Txn($txn);
# create some data
my %data = (
"red" => "boat",
"green" => "house",
"blue" => "sea",
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
my $key;
$ret += $db1->db_put($key, $v, DB_APPEND) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
#ok $txn->txn_abort() == 0 ;
ok (($Z = $txn->txn_abort()) == 0) ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
exit;
{
# DB_DUP
my $lex = new LexFile $Dfile ;
my %hash ;
ok my $db = tie %hash, 'BerkeleyDB::Heap', -Filename => $Dfile,
-Property => DB_DUP,
-Flags => DB_CREATE ;
$hash{'Wall'} = 'Larry' ;
$hash{'Wall'} = 'Stone' ;
$hash{'Smith'} = 'John' ;
$hash{'Wall'} = 'Brick' ;
$hash{'Wall'} = 'Brick' ;
$hash{'mouse'} = 'mickey' ;
ok keys %hash == 6 ;
# create a cursor
ok my $cursor = $db->db_cursor() ;
my $key = "Wall" ;
my $value ;
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key eq "Wall" && $value eq "Larry" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Stone" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
#my $ref = $db->db_stat() ;
#ok ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
undef $db ;
undef $cursor ;
untie %hash ;
}
{
# db_stat
my $lex = new LexFile $Dfile ;
my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
my %hash ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
-Flags => DB_CREATE,
-Minkey =>3 ,
-Pagesize => 2 **12
;
my $ref = $db->db_stat() ;
ok $ref->{$recs} == 0;
ok $ref->{'bt_minkey'} == 3;
ok $ref->{'bt_pagesize'} == 2 ** 12;
# create some data
my %data = (
"red" => 2,
"green" => "house",
"blue" => "sea",
) ;
my $ret = 0 ;
while (($k, $v) = each %data) {
$ret += $db->db_put($k, $v) ;
}
ok $ret == 0 ;
$ref = $db->db_stat() ;
ok $ref->{$recs} == 3;
}
{
# sub-class test
package Another ;
use strict ;
open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
print FILE <<'EOM' ;
package SubDB ;
use strict ;
use vars qw( @ISA @EXPORT) ;
require Exporter ;
use BerkeleyDB;
@ISA=qw(BerkeleyDB BerkeleyDB::Heap );
@EXPORT = @BerkeleyDB::EXPORT ;
sub db_put {
( run in 0.550 second using v1.01-cache-2.11-cpan-39bf76dae61 )