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