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