1#!./perl -w 2 3# ID: %I%, %G% 4 5use strict ; 6 7use lib 't' ; 8use BerkeleyDB; 9use Test::More; 10use util; 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 use Test::More; 650 BEGIN { push @INC, '.'; } 651 eval 'use SubDB ; '; 652 ok $@ eq "" ; 653 my @h ; 654 my $X ; 655 my $rec_len = 34 ; 656 eval ' 657 $X = tie(@h, "SubDB", -Filename => "dbqueue.tmp", 658 -Flags => DB_CREATE, 659 -Mode => 0640 , 660 -Len => $rec_len, 661 -Pad => " " 662 ); 663 ' ; 664 665 ok $@ eq "" ; 666 667 my $ret = eval '$h[1] = 3 ; return $h[1] ' ; 668 ok $@ eq "" ; 669 ok $ret == 7 ; 670 671 my $value = 0; 672 $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ; 673 ok $@ eq "" ; 674 ok $ret == 10 ; 675 676 $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; 677 ok $@ eq "" ; 678 ok $ret == 1 ; 679 680 $ret = eval '$X->A_new_method(1) ' ; 681 ok $@ eq "" ; 682 ok $ret eq "[[10]]" ; 683 684 undef $X ; 685 untie @h ; 686 unlink "SubDB.pm", "dbqueue.tmp" ; 687 688} 689 690{ 691 # DB_APPEND 692 693 my $lex = new LexFile $Dfile; 694 my @array ; 695 my $value ; 696 my $rec_len = 21 ; 697 ok my $db = tie @array, 'BerkeleyDB::Queue', 698 -Filename => $Dfile, 699 -Flags => DB_CREATE , 700 -Len => $rec_len, 701 -Pad => " " ; 702 703 # create a few records 704 $array[1] = "def" ; 705 $array[3] = "ghi" ; 706 707 my $k = 0 ; 708 ok $db->db_put($k, "fred", DB_APPEND) == 0 ; 709 ok $k == 4 ; 710 ok $array[4] eq fillout("fred", $rec_len) ; 711 712 undef $db ; 713 untie @array ; 714} 715 716{ 717 # 23 Sept 2001 -- push into an empty array 718 my $lex = new LexFile $Dfile ; 719 my @array ; 720 my $db ; 721 my $rec_len = 21 ; 722 ok $db = tie @array, 'BerkeleyDB::Queue', 723 -Flags => DB_CREATE , 724 -ArrayBase => 0, 725 -Len => $rec_len, 726 -Pad => " " , 727 -Filename => $Dfile ; 728 $FA ? push @array, "first" 729 : $db->push("first") ; 730 731 ok (($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len)) ; 732 733 undef $db; 734 untie @array ; 735 736} 737 738{ 739 # Tied Array interface with transactions 740 741 my $lex = new LexFile $Dfile ; 742 my @array ; 743 my $db ; 744 my $rec_len = 10 ; 745 my $home = "./fred" ; 746 ok my $lexD = new LexDir($home); 747 ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile, 748 -Flags => DB_CREATE|DB_INIT_TXN| 749 DB_INIT_MPOOL|DB_INIT_LOCK ; 750 ok my $txn = $env->txn_begin() ; 751 ok $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile, 752 -ArrayBase => 0, 753 -Flags => DB_CREATE , 754 -Env => $env , 755 -Txn => $txn , 756 -Len => $rec_len; 757 758 ok $txn->txn_commit() == 0 ; 759 ok $txn = $env->txn_begin() ; 760 $db->Txn($txn); 761 762 ok my $cursor = (tied @array)->db_cursor() ; 763 # check the database is empty 764 my $count = 0 ; 765 my ($k, $v) = (0,"") ; 766 while ($cursor->c_get($k, $v, DB_NEXT) == 0) { 767 ++ $count ; 768 } 769 ok $cursor->status() == DB_NOTFOUND ; 770 ok $count == 0 ; 771 772 ok @array == 0 ; 773 774 # Add a k/v pair 775 my $value ; 776 $array[1] = "some value"; 777 ok ((tied @array)->status() == 0) ; 778 ok $array[1] eq fillout("some value", $rec_len); 779 ok defined $array[1]; 780 ok ((tied @array)->status() == 0) ; 781 ok !defined $array[3]; 782 ok ((tied @array)->status() == DB_NOTFOUND) ; 783 784 $array[1] = 2 ; 785 $array[10] = 20 ; 786 $array[100] = 200 ; 787 788 my ($keys, $values) = (0,0); 789 $count = 0 ; 790 for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ; 791 $status == 0 ; 792 $status = $cursor->c_get($k, $v, DB_NEXT)) { 793 $keys += $k ; 794 $values += $v ; 795 ++ $count ; 796 } 797 ok $count == 3 ; 798 ok $keys == 111 ; 799 ok $values == 222 ; 800 801 # unshift isn't allowed 802# eval { 803# $FA ? unshift @array, "red", "green", "blue" 804# : $db->unshift("red", "green", "blue" ) ; 805# } ; 806# ok $@ =~ /^unshift is unsupported with Queue databases/ ; 807 $array[0] = "red" ; 808 $array[1] = "green" ; 809 $array[2] = "blue" ; 810 $array[4] = 2 ; 811 ok $array[0] eq fillout("red", $rec_len) ; 812 ok $cursor->c_get($k, $v, DB_FIRST) == 0 ; 813 ok $k == 0 ; 814 ok $v eq fillout("red", $rec_len) ; 815 ok $array[1] eq fillout("green", $rec_len) ; 816 ok $cursor->c_get($k, $v, DB_NEXT) == 0 ; 817 ok $k == 1 ; 818 ok $v eq fillout("green", $rec_len) ; 819 ok $array[2] eq fillout("blue", $rec_len) ; 820 ok $cursor->c_get($k, $v, DB_NEXT) == 0 ; 821 ok $k == 2 ; 822 ok $v eq fillout("blue", $rec_len) ; 823 ok $array[4] == 2 ; 824 ok $cursor->c_get($k, $v, DB_NEXT) == 0 ; 825 ok $k == 4 ; 826 ok $v == 2 ; 827 828 # shift 829 ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ; 830 ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ; 831 ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ; 832 ok (($FA ? shift @array : $db->shift()) == 2) ; 833 834 # push 835 $FA ? push @array, "the", "end" 836 : $db->push("the", "end") ; 837 ok $cursor->c_get($k, $v, DB_LAST) == 0 ; 838 ok $k == 102 ; 839 ok $v eq fillout("end", $rec_len) ; 840 ok $cursor->c_get($k, $v, DB_PREV) == 0 ; 841 ok $k == 101 ; 842 ok $v eq fillout("the", $rec_len) ; 843 ok $cursor->c_get($k, $v, DB_PREV) == 0 ; 844 ok $k == 100 ; 845 ok $v == 200 ; 846 847 # pop 848 ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ; 849 ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ; 850 ok (( $FA ? pop @array : $db->pop ) == 200 ) ; 851 852 # now clear the array 853 $FA ? @array = () 854 : $db->clear() ; 855 ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ; 856 undef $cursor ; 857 ok $txn->txn_commit() == 0 ; 858 859 undef $db ; 860 untie @array ; 861} 862__END__ 863 864 865# TODO 866# 867# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records 868