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