1#!./perl -w 2 3use strict ; 4 5use lib 't'; 6use BerkeleyDB; 7use util ; 8use Test::More; 9 10plan tests => 244; 11 12my $Dfile = "dbhash.tmp"; 13my $Dfile2 = "dbhash2.tmp"; 14my $Dfile3 = "dbhash3.tmp"; 15unlink $Dfile; 16 17umask(0) ; 18 19 20# Check for invalid parameters 21{ 22 # Check for invalid parameters 23 my $db ; 24 eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ; 25 ok $@ =~ /unknown key value\(s\) Stupid/ ; 26 27 eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; 28 ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ 29 or print "# $@" ; 30 31 eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ; 32 ok $@ =~ /^Env not of type BerkeleyDB::Env/ ; 33 34 eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ; 35 ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; 36 37 my $obj = bless [], "main" ; 38 eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ; 39 ok $@ =~ /^Env not of type BerkeleyDB::Env/ ; 40} 41 42# Now check the interface to Btree 43 44{ 45 my $lex = new LexFile $Dfile ; 46 47 ok my $db = new BerkeleyDB::Btree -Filename => $Dfile, 48 -Flags => DB_CREATE ; 49 50 # Add a k/v pair 51 my $value ; 52 my $status ; 53 ok $db->db_put("some key", "some value") == 0 ; 54 ok $db->status() == 0 ; 55 ok $db->db_get("some key", $value) == 0 ; 56 ok $value eq "some value" ; 57 ok $db->db_put("key", "value") == 0 ; 58 ok $db->db_get("key", $value) == 0 ; 59 ok $value eq "value" ; 60 ok $db->db_del("some key") == 0 ; 61 ok $db->db_get("some key", $value) == DB_NOTFOUND ; 62 ok $db->status() == DB_NOTFOUND ; 63 ok $db->status() eq $DB_errors{'DB_NOTFOUND'} ; 64 65 ok $db->db_sync() == 0 ; 66 67 # Check NOOVERWRITE will make put fail when attempting to overwrite 68 # an existing record. 69 70 ok $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; 71 ok $db->status() eq $DB_errors{'DB_KEYEXIST'} ; 72 ok $db->status() == DB_KEYEXIST ; 73 74 75 # check that the value of the key has not been changed by the 76 # previous test 77 ok $db->db_get("key", $value) == 0 ; 78 ok $value eq "value" ; 79 80 # test DB_GET_BOTH 81 my ($k, $v) = ("key", "value") ; 82 ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ; 83 84 ($k, $v) = ("key", "fred") ; 85 ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; 86 87 ($k, $v) = ("another", "value") ; 88 ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; 89 90 91} 92 93{ 94 # Check simple env works with a hash. 95 my $lex = new LexFile $Dfile ; 96 97 my $home = "./fred" ; 98 ok my $lexD = new LexDir($home) ; 99 100 ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, 101 @StdErrFile, -Home => $home ; 102 ok my $db = new BerkeleyDB::Btree -Filename => $Dfile, 103 -Env => $env, 104 -Flags => DB_CREATE ; 105 106 # Add a k/v pair 107 my $value ; 108 ok $db->db_put("some key", "some value") == 0 ; 109 ok $db->db_get("some key", $value) == 0 ; 110 ok $value eq "some value" ; 111 undef $db ; 112 undef $env ; 113} 114 115 116{ 117 # cursors 118 119 my $lex = new LexFile $Dfile ; 120 my %hash ; 121 my ($k, $v) ; 122 ok my $db = new BerkeleyDB::Btree -Filename => $Dfile, 123 -Flags => DB_CREATE ; 124 #print "[$db] [$!] $BerkeleyDB::Error\n" ; 125 126 # create some data 127 my %data = ( 128 "red" => 2, 129 "green" => "house", 130 "blue" => "sea", 131 ) ; 132 133 my $ret = 0 ; 134 while (($k, $v) = each %data) { 135 $ret += $db->db_put($k, $v) ; 136 } 137 ok $ret == 0 ; 138 139 # create the cursor 140 ok my $cursor = $db->db_cursor() ; 141 142 $k = $v = "" ; 143 my %copy = %data ; 144 my $extras = 0 ; 145 # sequence forwards 146 while ($cursor->c_get($k, $v, DB_NEXT) == 0) { 147 if ( $copy{$k} eq $v ) 148 { delete $copy{$k} } 149 else 150 { ++ $extras } 151 } 152 ok $cursor->status() == DB_NOTFOUND ; 153 ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'}; 154 ok keys %copy == 0 ; 155 ok $extras == 0 ; 156 157 # sequence backwards 158 %copy = %data ; 159 $extras = 0 ; 160 my $status ; 161 for ( $status = $cursor->c_get($k, $v, DB_LAST) ; 162 $status == 0 ; 163 $status = $cursor->c_get($k, $v, DB_PREV)) { 164 if ( $copy{$k} eq $v ) 165 { delete $copy{$k} } 166 else 167 { ++ $extras } 168 } 169 ok $status == DB_NOTFOUND ; 170 ok $status eq $DB_errors{'DB_NOTFOUND'}; 171 ok $cursor->status() == $status ; 172 ok $cursor->status() eq $status ; 173 ok keys %copy == 0 ; 174 ok $extras == 0 ; 175 176 ($k, $v) = ("green", "house") ; 177 ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ; 178 179 ($k, $v) = ("green", "door") ; 180 ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; 181 182 ($k, $v) = ("black", "house") ; 183 ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; 184 185} 186 187{ 188 # Tied Hash interface 189 190 my $lex = new LexFile $Dfile ; 191 my %hash ; 192 ok tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, 193 -Flags => DB_CREATE ; 194 195 # check "each" with an empty database 196 my $count = 0 ; 197 while (my ($k, $v) = each %hash) { 198 ++ $count ; 199 } 200 ok ((tied %hash)->status() == DB_NOTFOUND) ; 201 ok $count == 0 ; 202 203 # Add a k/v pair 204 my $value ; 205 $hash{"some key"} = "some value"; 206 ok ((tied %hash)->status() == 0) ; 207 ok $hash{"some key"} eq "some value"; 208 ok defined $hash{"some key"} ; 209 ok ((tied %hash)->status() == 0) ; 210 ok exists $hash{"some key"} ; 211 ok !defined $hash{"jimmy"} ; 212 ok ((tied %hash)->status() == DB_NOTFOUND) ; 213 ok !exists $hash{"jimmy"} ; 214 ok ((tied %hash)->status() == DB_NOTFOUND) ; 215 216 delete $hash{"some key"} ; 217 ok ((tied %hash)->status() == 0) ; 218 ok ! defined $hash{"some key"} ; 219 ok ((tied %hash)->status() == DB_NOTFOUND) ; 220 ok ! exists $hash{"some key"} ; 221 ok ((tied %hash)->status() == DB_NOTFOUND) ; 222 223 $hash{1} = 2 ; 224 $hash{10} = 20 ; 225 $hash{1000} = 2000 ; 226 227 my ($keys, $values) = (0,0); 228 $count = 0 ; 229 while (my ($k, $v) = each %hash) { 230 $keys += $k ; 231 $values += $v ; 232 ++ $count ; 233 } 234 ok $count == 3 ; 235 ok $keys == 1011 ; 236 ok $values == 2022 ; 237 238 # now clear the hash 239 %hash = () ; 240 ok keys %hash == 0 ; 241 242 untie %hash ; 243} 244 245{ 246 # override default compare 247 my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; 248 my $value ; 249 my (%h, %g, %k) ; 250 my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; 251 ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 252 -Compare => sub { $_[0] <=> $_[1] }, 253 -Flags => DB_CREATE ; 254 255 ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 256 -Compare => sub { $_[0] cmp $_[1] }, 257 -Flags => DB_CREATE ; 258 259 ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, 260 -Compare => sub { length $_[0] <=> length $_[1] }, 261 -Flags => DB_CREATE ; 262 263 my @srt_1 ; 264 { local $^W = 0 ; 265 @srt_1 = sort { $a <=> $b } @Keys ; 266 } 267 my @srt_2 = sort { $a cmp $b } @Keys ; 268 my @srt_3 = sort { length $a <=> length $b } @Keys ; 269 270 foreach (@Keys) { 271 local $^W = 0 ; 272 $h{$_} = 1 ; 273 $g{$_} = 1 ; 274 $k{$_} = 1 ; 275 } 276 277 sub ArrayCompare 278 { 279 my($a, $b) = @_ ; 280 281 return 0 if @$a != @$b ; 282 283 foreach (1 .. length @$a) 284 { 285 return 0 unless $$a[$_] eq $$b[$_] ; 286 } 287 288 1 ; 289 } 290 291 ok ArrayCompare (\@srt_1, [keys %h]); 292 ok ArrayCompare (\@srt_2, [keys %g]); 293 ok ArrayCompare (\@srt_3, [keys %k]); 294 295} 296 297{ 298 # override default compare, with duplicates, don't sort values 299 my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; 300 my $value ; 301 my (%h, %g, %k) ; 302 my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ; 303 my @Values = qw( 1 0 3 dd x abc 0 ) ; 304 ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 305 -Compare => sub { $_[0] <=> $_[1] }, 306 -Property => DB_DUP, 307 -Flags => DB_CREATE ; 308 309 ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 310 -Compare => sub { $_[0] cmp $_[1] }, 311 -Property => DB_DUP, 312 -Flags => DB_CREATE ; 313 314 ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, 315 -Compare => sub { length $_[0] <=> length $_[1] }, 316 -Property => DB_DUP, 317 -Flags => DB_CREATE ; 318 319 my @srt_1 ; 320 { local $^W = 0 ; 321 @srt_1 = sort { $a <=> $b } @Keys ; 322 } 323 my @srt_2 = sort { $a cmp $b } @Keys ; 324 my @srt_3 = sort { length $a <=> length $b } @Keys ; 325 326 foreach (@Keys) { 327 local $^W = 0 ; 328 my $value = shift @Values ; 329 $h{$_} = $value ; 330 $g{$_} = $value ; 331 $k{$_} = $value ; 332 } 333 334 sub getValues 335 { 336 my $hash = shift ; 337 my $db = tied %$hash ; 338 my $cursor = $db->db_cursor() ; 339 my @values = () ; 340 my ($k, $v) = (0,0) ; 341 while ($cursor->c_get($k, $v, DB_NEXT) == 0) { 342 push @values, $v ; 343 } 344 return @values ; 345 } 346 347 ok ArrayCompare (\@srt_1, [keys %h]); 348 ok ArrayCompare (\@srt_2, [keys %g]); 349 ok ArrayCompare (\@srt_3, [keys %k]); 350 ok ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]); 351 ok ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]); 352 ok ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]); 353 354 # test DB_DUP_NEXT 355 ok my $cur = (tied %g)->db_cursor() ; 356 my ($k, $v) = (9, "") ; 357 ok $cur->c_get($k, $v, DB_SET) == 0 ; 358 ok $k == 9 && $v == 0 ; 359 ok $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ; 360 ok $k == 9 && $v eq "x" ; 361 ok $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ; 362} 363 364{ 365 # override default compare, with duplicates, sort values 366 my $lex = new LexFile $Dfile, $Dfile2; 367 my $value ; 368 my (%h, %g) ; 369 my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ; 370 my @Values = qw( 1 11 3 dd x abc 2 0 ) ; 371 ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 372 -Compare => sub { $_[0] <=> $_[1] }, 373 -DupCompare => sub { $_[0] cmp $_[1] }, 374 -Property => DB_DUP, 375 -Flags => DB_CREATE ; 376 377 ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 378 -Compare => sub { $_[0] cmp $_[1] }, 379 -DupCompare => sub { $_[0] <=> $_[1] }, 380 -Property => DB_DUP, 381 382 383 384 -Flags => DB_CREATE ; 385 386 my @srt_1 ; 387 { local $^W = 0 ; 388 @srt_1 = sort { $a <=> $b } @Keys ; 389 } 390 my @srt_2 = sort { $a cmp $b } @Keys ; 391 392 foreach (@Keys) { 393 local $^W = 0 ; 394 my $value = shift @Values ; 395 $h{$_} = $value ; 396 $g{$_} = $value ; 397 } 398 399 ok ArrayCompare (\@srt_1, [keys %h]); 400 ok ArrayCompare (\@srt_2, [keys %g]); 401 ok ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]); 402 ok ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]); 403 404} 405 406{ 407 # get_dup etc 408 my $lex = new LexFile $Dfile; 409 my %hh ; 410 411 ok my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile, 412 -DupCompare => sub { $_[0] cmp $_[1] }, 413 -Property => DB_DUP, 414 -Flags => DB_CREATE ; 415 416 $hh{'Wall'} = 'Larry' ; 417 $hh{'Wall'} = 'Stone' ; # Note the duplicate key 418 $hh{'Wall'} = 'Brick' ; # Note the duplicate key 419 $hh{'Smith'} = 'John' ; 420 $hh{'mouse'} = 'mickey' ; 421 422 # first work in scalar context 423 ok scalar $YY->get_dup('Unknown') == 0 ; 424 ok scalar $YY->get_dup('Smith') == 1 ; 425 ok scalar $YY->get_dup('Wall') == 3 ; 426 427 # now in list context 428 my @unknown = $YY->get_dup('Unknown') ; 429 ok "@unknown" eq "" ; 430 431 my @smith = $YY->get_dup('Smith') ; 432 ok "@smith" eq "John" ; 433 434 { 435 my @wall = $YY->get_dup('Wall') ; 436 my %wall ; 437 @wall{@wall} = @wall ; 438 ok (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}); 439 } 440 441 # hash 442 my %unknown = $YY->get_dup('Unknown', 1) ; 443 ok keys %unknown == 0 ; 444 445 my %smith = $YY->get_dup('Smith', 1) ; 446 ok keys %smith == 1 && $smith{'John'} ; 447 448 my %wall = $YY->get_dup('Wall', 1) ; 449 ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 450 && $wall{'Brick'} == 1 ; 451 452 undef $YY ; 453 untie %hh ; 454 455} 456 457{ 458 # in-memory file 459 460 my $lex = new LexFile $Dfile ; 461 my %hash ; 462 my $fd ; 463 my $value ; 464 ok my $db = tie %hash, 'BerkeleyDB::Btree' ; 465 466 ok $db->db_put("some key", "some value") == 0 ; 467 ok $db->db_get("some key", $value) == 0 ; 468 ok $value eq "some value" ; 469 470} 471 472{ 473 # partial 474 # check works via API 475 476 my $lex = new LexFile $Dfile ; 477 my $value ; 478 ok my $db = new BerkeleyDB::Btree -Filename => $Dfile, 479 -Flags => DB_CREATE ; 480 481 # create some data 482 my %data = ( 483 "red" => "boat", 484 "green" => "house", 485 "blue" => "sea", 486 ) ; 487 488 my $ret = 0 ; 489 while (my ($k, $v) = each %data) { 490 $ret += $db->db_put($k, $v) ; 491 } 492 ok $ret == 0 ; 493 494 495 # do a partial get 496 my ($pon, $off, $len) = $db->partial_set(0,2) ; 497 ok ! $pon && $off == 0 && $len == 0 ; 498 ok $db->db_get("red", $value) == 0 && $value eq "bo" ; 499 ok $db->db_get("green", $value) == 0 && $value eq "ho" ; 500 ok $db->db_get("blue", $value) == 0 && $value eq "se" ; 501 502 # do a partial get, off end of data 503 ($pon, $off, $len) = $db->partial_set(3,2) ; 504 ok $pon ; 505 ok $off == 0 ; 506 ok $len == 2 ; 507 ok $db->db_get("red", $value) == 0 && $value eq "t" ; 508 ok $db->db_get("green", $value) == 0 && $value eq "se" ; 509 ok $db->db_get("blue", $value) == 0 && $value eq "" ; 510 511 # switch of partial mode 512 ($pon, $off, $len) = $db->partial_clear() ; 513 ok $pon ; 514 ok $off == 3 ; 515 ok $len == 2 ; 516 ok $db->db_get("red", $value) == 0 && $value eq "boat" ; 517 ok $db->db_get("green", $value) == 0 && $value eq "house" ; 518 ok $db->db_get("blue", $value) == 0 && $value eq "sea" ; 519 520 # now partial put 521 $db->partial_set(0,2) ; 522 ok $db->db_put("red", "") == 0 ; 523 ok $db->db_put("green", "AB") == 0 ; 524 ok $db->db_put("blue", "XYZ") == 0 ; 525 ok $db->db_put("new", "KLM") == 0 ; 526 527 ($pon, $off, $len) = $db->partial_clear() ; 528 ok $pon ; 529 ok $off == 0 ; 530 ok $len == 2 ; 531 ok $db->db_get("red", $value) == 0 && $value eq "at" ; 532 ok $db->db_get("green", $value) == 0 && $value eq "ABuse" ; 533 ok $db->db_get("blue", $value) == 0 && $value eq "XYZa" ; 534 ok $db->db_get("new", $value) == 0 && $value eq "KLM" ; 535 536 # now partial put 537 ($pon, $off, $len) = $db->partial_set(3,2) ; 538 ok ! $pon ; 539 ok $off == 0 ; 540 ok $len == 0 ; 541 ok $db->db_put("red", "PPP") == 0 ; 542 ok $db->db_put("green", "Q") == 0 ; 543 ok $db->db_put("blue", "XYZ") == 0 ; 544 ok $db->db_put("new", "TU") == 0 ; 545 546 $db->partial_clear() ; 547 ok $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ; 548 ok $db->db_get("green", $value) == 0 && $value eq "ABuQ" ; 549 ok $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ; 550 ok $db->db_get("new", $value) == 0 && $value eq "KLMTU" ; 551} 552 553{ 554 # partial 555 # check works via tied hash 556 557 my $lex = new LexFile $Dfile ; 558 my %hash ; 559 my $value ; 560 ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, 561 -Flags => DB_CREATE ; 562 563 # create some data 564 my %data = ( 565 "red" => "boat", 566 "green" => "house", 567 "blue" => "sea", 568 ) ; 569 570 while (my ($k, $v) = each %data) { 571 $hash{$k} = $v ; 572 } 573 574 575 # do a partial get 576 $db->partial_set(0,2) ; 577 ok $hash{"red"} eq "bo" ; 578 ok $hash{"green"} eq "ho" ; 579 ok $hash{"blue"} eq "se" ; 580 581 # do a partial get, off end of data 582 $db->partial_set(3,2) ; 583 ok $hash{"red"} eq "t" ; 584 ok $hash{"green"} eq "se" ; 585 ok $hash{"blue"} eq "" ; 586 587 # switch of partial mode 588 $db->partial_clear() ; 589 ok $hash{"red"} eq "boat" ; 590 ok $hash{"green"} eq "house" ; 591 ok $hash{"blue"} eq "sea" ; 592 593 # now partial put 594 $db->partial_set(0,2) ; 595 ok $hash{"red"} = "" ; 596 ok $hash{"green"} = "AB" ; 597 ok $hash{"blue"} = "XYZ" ; 598 ok $hash{"new"} = "KLM" ; 599 600 $db->partial_clear() ; 601 ok $hash{"red"} eq "at" ; 602 ok $hash{"green"} eq "ABuse" ; 603 ok $hash{"blue"} eq "XYZa" ; 604 ok $hash{"new"} eq "KLM" ; 605 606 # now partial put 607 $db->partial_set(3,2) ; 608 ok $hash{"red"} = "PPP" ; 609 ok $hash{"green"} = "Q" ; 610 ok $hash{"blue"} = "XYZ" ; 611 ok $hash{"new"} = "TU" ; 612 613 $db->partial_clear() ; 614 ok $hash{"red"} eq "at\0PPP" ; 615 ok $hash{"green"} eq "ABuQ" ; 616 ok $hash{"blue"} eq "XYZXYZ" ; 617 ok $hash{"new"} eq "KLMTU" ; 618} 619 620{ 621 # transaction 622 623 my $lex = new LexFile $Dfile ; 624 my %hash ; 625 my $value ; 626 627 my $home = "./fred" ; 628 ok my $lexD = new LexDir($home) ; 629 ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile, 630 -Flags => DB_CREATE|DB_INIT_TXN| 631 DB_INIT_MPOOL|DB_INIT_LOCK ; 632 ok my $txn = $env->txn_begin() ; 633 ok my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, 634 -Flags => DB_CREATE , 635 -Env => $env, 636 -Txn => $txn ; 637 638 ok ((my $Z = $txn->txn_commit()) == 0) ; 639 ok $txn = $env->txn_begin() ; 640 $db1->Txn($txn); 641 642 # create some data 643 my %data = ( 644 "red" => "boat", 645 "green" => "house", 646 "blue" => "sea", 647 ) ; 648 649 my $ret = 0 ; 650 while (my ($k, $v) = each %data) { 651 $ret += $db1->db_put($k, $v) ; 652 } 653 ok $ret == 0 ; 654 655 # should be able to see all the records 656 657 ok my $cursor = $db1->db_cursor() ; 658 my ($k, $v) = ("", "") ; 659 my $count = 0 ; 660 # sequence forwards 661 while ($cursor->c_get($k, $v, DB_NEXT) == 0) { 662 ++ $count ; 663 } 664 ok $count == 3 ; 665 undef $cursor ; 666 667 # now abort the transaction 668 #ok $txn->txn_abort() == 0 ; 669 ok (($Z = $txn->txn_abort()) == 0) ; 670 671 # there shouldn't be any records in the database 672 $count = 0 ; 673 # sequence forwards 674 ok $cursor = $db1->db_cursor() ; 675 while ($cursor->c_get($k, $v, DB_NEXT) == 0) { 676 ++ $count ; 677 } 678 ok $count == 0 ; 679 680 undef $txn ; 681 undef $cursor ; 682 undef $db1 ; 683 undef $env ; 684 untie %hash ; 685} 686 687{ 688 # DB_DUP 689 690 my $lex = new LexFile $Dfile ; 691 my %hash ; 692 ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, 693 -Property => DB_DUP, 694 -Flags => DB_CREATE ; 695 696 $hash{'Wall'} = 'Larry' ; 697 $hash{'Wall'} = 'Stone' ; 698 $hash{'Smith'} = 'John' ; 699 $hash{'Wall'} = 'Brick' ; 700 $hash{'Wall'} = 'Brick' ; 701 $hash{'mouse'} = 'mickey' ; 702 703 ok keys %hash == 6 ; 704 705 # create a cursor 706 ok my $cursor = $db->db_cursor() ; 707 708 my $key = "Wall" ; 709 my $value ; 710 ok $cursor->c_get($key, $value, DB_SET) == 0 ; 711 ok $key eq "Wall" && $value eq "Larry" ; 712 ok $cursor->c_get($key, $value, DB_NEXT) == 0 ; 713 ok $key eq "Wall" && $value eq "Stone" ; 714 ok $cursor->c_get($key, $value, DB_NEXT) == 0 ; 715 ok $key eq "Wall" && $value eq "Brick" ; 716 ok $cursor->c_get($key, $value, DB_NEXT) == 0 ; 717 ok $key eq "Wall" && $value eq "Brick" ; 718 719 #my $ref = $db->db_stat() ; 720 #ok ($ref->{bt_flags} | DB_DUP) == DB_DUP ; 721#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n"; 722 723 undef $db ; 724 undef $cursor ; 725 untie %hash ; 726 727} 728 729{ 730 # db_stat 731 732 my $lex = new LexFile $Dfile ; 733 my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ; 734 my %hash ; 735 my ($k, $v) ; 736 ok my $db = new BerkeleyDB::Btree -Filename => $Dfile, 737 -Flags => DB_CREATE, 738 -Minkey =>3 , 739 -Pagesize => 2 **12 740 ; 741 742 my $ref = $db->db_stat() ; 743 ok $ref->{$recs} == 0; 744 ok $ref->{'bt_minkey'} == 3; 745 ok $ref->{'bt_pagesize'} == 2 ** 12; 746 747 # create some data 748 my %data = ( 749 "red" => 2, 750 "green" => "house", 751 "blue" => "sea", 752 ) ; 753 754 my $ret = 0 ; 755 while (($k, $v) = each %data) { 756 $ret += $db->db_put($k, $v) ; 757 } 758 ok $ret == 0 ; 759 760 $ref = $db->db_stat() ; 761 ok $ref->{$recs} == 3; 762} 763 764{ 765 # sub-class test 766 767 package Another ; 768 769 use strict ; 770 771 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; 772 print FILE <<'EOM' ; 773 774 package SubDB ; 775 776 use strict ; 777 use vars qw( @ISA @EXPORT) ; 778 779 require Exporter ; 780 use BerkeleyDB; 781 @ISA=qw(BerkeleyDB BerkeleyDB::Btree ); 782 @EXPORT = @BerkeleyDB::EXPORT ; 783 784 sub db_put { 785 my $self = shift ; 786 my $key = shift ; 787 my $value = shift ; 788 $self->SUPER::db_put($key, $value * 3) ; 789 } 790 791 sub db_get { 792 my $self = shift ; 793 $self->SUPER::db_get($_[0], $_[1]) ; 794 $_[1] -= 2 ; 795 } 796 797 sub A_new_method 798 { 799 my $self = shift ; 800 my $key = shift ; 801 my $value = $self->FETCH($key) ; 802 return "[[$value]]" ; 803 } 804 805 1 ; 806EOM 807 808 close FILE ; 809 810 use Test::More; 811 BEGIN { push @INC, '.'; } 812 eval 'use SubDB ; '; 813 ok $@ eq "" ; 814 my %h ; 815 my $X ; 816 eval ' 817 $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp", 818 -Flags => DB_CREATE, 819 -Mode => 0640 ); 820 ' ; 821 822 ok $@ eq "" && $X ; 823 824 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; 825 ok $@ eq "" ; 826 ok $ret == 7 ; 827 828 my $value = 0; 829 $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ; 830 ok $@ eq "" ; 831 ok $ret == 10 ; 832 833 $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; 834 ok $@ eq "" ; 835 ok $ret == 1 ; 836 837 $ret = eval '$X->A_new_method("joe") ' ; 838 ok $@ eq "" ; 839 ok $ret eq "[[10]]" ; 840 841 undef $X; 842 untie %h; 843 unlink "SubDB.pm", "dbbtree.tmp" ; 844 845} 846 847{ 848 # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO 849 850 my $lex = new LexFile $Dfile ; 851 my %hash ; 852 my ($k, $v) = ("", ""); 853 ok my $db = new BerkeleyDB::Btree 854 -Filename => $Dfile, 855 -Flags => DB_CREATE, 856 -Property => DB_RECNUM ; 857 858 859 # create some data 860 my @data = ( 861 "A zero", 862 "B one", 863 "C two", 864 "D three", 865 "E four" 866 ) ; 867 868 my $ix = 0 ; 869 my $ret = 0 ; 870 foreach (@data) { 871 $ret += $db->db_put($_, $ix) ; 872 ++ $ix ; 873 } 874 ok $ret == 0 ; 875 876 # db_get & DB_SET_RECNO 877 $k = 1 ; 878 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 879 ok $k eq "B one" && $v == 1 ; 880 881 $k = 3 ; 882 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 883 ok $k eq "D three" && $v == 3 ; 884 885 $k = 4 ; 886 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 887 ok $k eq "E four" && $v == 4 ; 888 889 $k = 0 ; 890 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 891 ok $k eq "A zero" && $v == 0 ; 892 893 # cursor & DB_SET_RECNO 894 895 # create the cursor 896 ok my $cursor = $db->db_cursor() ; 897 898 $k = 2 ; 899 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 900 ok $k eq "C two" && $v == 2 ; 901 902 $k = 0 ; 903 ok $cursor->c_get($k, $v, DB_SET_RECNO) == 0; 904 ok $k eq "A zero" && $v == 0 ; 905 906 $k = 3 ; 907 ok $db->db_get($k, $v, DB_SET_RECNO) == 0; 908 ok $k eq "D three" && $v == 3 ; 909 910 # cursor & DB_GET_RECNO 911 ok $cursor->c_get($k, $v, DB_FIRST) == 0 ; 912 ok $k eq "A zero" && $v == 0 ; 913 ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0; 914 ok $v == 0 ; 915 916 ok $cursor->c_get($k, $v, DB_NEXT) == 0 ; 917 ok $k eq "B one" && $v == 1 ; 918 ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0; 919 ok $v == 1 ; 920 921 ok $cursor->c_get($k, $v, DB_LAST) == 0 ; 922 ok $k eq "E four" && $v == 4 ; 923 ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0; 924 ok $v == 4 ; 925 926} 927 928