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