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