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