1#!./perl 2 3BEGIN { 4 unless(grep /blib/, @INC) { 5 chdir 't' if -d 't'; 6 @INC = '../lib' if -d '../lib'; 7 } 8} 9 10use warnings; 11use strict; 12use Config; 13 14BEGIN { 15 if(-d "lib" && -f "TEST") { 16 if ($Config{'extensions'} !~ /\bDB_File\b/ ) { 17 print "1..0 # Skip: DB_File was not built\n"; 18 exit 0; 19 } 20 } 21} 22 23use DB_File; 24use Fcntl; 25 26print "1..166\n"; 27 28unlink glob "__db.*"; 29 30sub ok 31{ 32 my $no = shift ; 33 my $result = shift ; 34 35 print "not " unless $result ; 36 print "ok $no\n" ; 37 38 return $result ; 39} 40 41{ 42 package Redirect ; 43 use Symbol ; 44 45 sub new 46 { 47 my $class = shift ; 48 my $filename = shift ; 49 my $fh = gensym ; 50 open ($fh, ">$filename") || die "Cannot open $filename: $!" ; 51 my $real_stdout = select($fh) ; 52 return bless [$fh, $real_stdout ] ; 53 54 } 55 sub DESTROY 56 { 57 my $self = shift ; 58 close $self->[0] ; 59 select($self->[1]) ; 60 } 61} 62 63sub docat_del 64{ 65 my $file = shift; 66 local $/ = undef; 67 open(CAT,$file) || die "Cannot open $file: $!"; 68 my $result = <CAT>; 69 close(CAT); 70 $result = normalise($result) ; 71 unlink $file ; 72 return $result; 73} 74 75sub normalise 76{ 77 my $data = shift ; 78 $data =~ s#\r\n#\n#g 79 if $^O eq 'cygwin' ; 80 return $data ; 81} 82 83sub safeUntie 84{ 85 my $hashref = shift ; 86 my $no_inner = 1; 87 local $SIG{__WARN__} = sub {-- $no_inner } ; 88 untie %$hashref; 89 return $no_inner; 90} 91 92 93my $Dfile = "dbhash.tmp"; 94my $Dfile2 = "dbhash2.tmp"; 95my $null_keys_allowed = ($DB_File::db_ver < 2.004010 96 || $DB_File::db_ver >= 3.1 ); 97 98unlink $Dfile; 99 100umask(0); 101 102# Check the interface to HASHINFO 103 104my $dbh = new DB_File::HASHINFO ; 105 106ok(1, ! defined $dbh->{bsize}) ; 107ok(2, ! defined $dbh->{ffactor}) ; 108ok(3, ! defined $dbh->{nelem}) ; 109ok(4, ! defined $dbh->{cachesize}) ; 110ok(5, ! defined $dbh->{hash}) ; 111ok(6, ! defined $dbh->{lorder}) ; 112 113$dbh->{bsize} = 3000 ; 114ok(7, $dbh->{bsize} == 3000 ); 115 116$dbh->{ffactor} = 9000 ; 117ok(8, $dbh->{ffactor} == 9000 ); 118 119$dbh->{nelem} = 400 ; 120ok(9, $dbh->{nelem} == 400 ); 121 122$dbh->{cachesize} = 65 ; 123ok(10, $dbh->{cachesize} == 65 ); 124 125my $some_sub = sub {} ; 126$dbh->{hash} = $some_sub; 127ok(11, $dbh->{hash} eq $some_sub ); 128 129$dbh->{lorder} = 1234 ; 130ok(12, $dbh->{lorder} == 1234 ); 131 132# Check that an invalid entry is caught both for store & fetch 133eval '$dbh->{fred} = 1234' ; 134ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); 135eval 'my $q = $dbh->{fred}' ; 136ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); 137 138 139# Now check the interface to HASH 140my ($X, %h); 141ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 142die "Could not tie: $!" unless $X; 143 144my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 145 $blksize,$blocks) = stat($Dfile); 146 147my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; 148 149ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) || 150 $noMode{$^O} ); 151 152my ($key, $value, $i); 153while (($key,$value) = each(%h)) { 154 $i++; 155} 156ok(17, !$i ); 157 158$h{'goner1'} = 'snork'; 159 160$h{'abc'} = 'ABC'; 161ok(18, $h{'abc'} eq 'ABC' ); 162ok(19, !defined $h{'jimmy'} ); 163ok(20, !exists $h{'jimmy'} ); 164ok(21, exists $h{'abc'} ); 165 166$h{'def'} = 'DEF'; 167$h{'jkl','mno'} = "JKL\034MNO"; 168$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); 169$h{'a'} = 'A'; 170 171#$h{'b'} = 'B'; 172$X->STORE('b', 'B') ; 173 174$h{'c'} = 'C'; 175 176#$h{'d'} = 'D'; 177$X->put('d', 'D') ; 178 179$h{'e'} = 'E'; 180$h{'f'} = 'F'; 181$h{'g'} = 'X'; 182$h{'h'} = 'H'; 183$h{'i'} = 'I'; 184 185$h{'goner2'} = 'snork'; 186delete $h{'goner2'}; 187 188 189# IMPORTANT - $X must be undefined before the untie otherwise the 190# underlying DB close routine will not get called. 191undef $X ; 192untie(%h); 193 194 195# tie to the same file again, do not supply a type - should default to HASH 196ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); 197 198# Modify an entry from the previous tie 199$h{'g'} = 'G'; 200 201$h{'j'} = 'J'; 202$h{'k'} = 'K'; 203$h{'l'} = 'L'; 204$h{'m'} = 'M'; 205$h{'n'} = 'N'; 206$h{'o'} = 'O'; 207$h{'p'} = 'P'; 208$h{'q'} = 'Q'; 209$h{'r'} = 'R'; 210$h{'s'} = 'S'; 211$h{'t'} = 'T'; 212$h{'u'} = 'U'; 213$h{'v'} = 'V'; 214$h{'w'} = 'W'; 215$h{'x'} = 'X'; 216$h{'y'} = 'Y'; 217$h{'z'} = 'Z'; 218 219$h{'goner3'} = 'snork'; 220 221delete $h{'goner1'}; 222$X->DELETE('goner3'); 223 224my @keys = keys(%h); 225my @values = values(%h); 226 227ok(23, $#keys == 29 && $#values == 29) ; 228 229$i = 0 ; 230while (($key,$value) = each(%h)) { 231 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { 232 $key =~ y/a-z/A-Z/; 233 $i++ if $key eq $value; 234 } 235} 236 237ok(24, $i == 30) ; 238 239@keys = ('blurfl', keys(%h), 'dyick'); 240ok(25, $#keys == 31) ; 241 242$h{'foo'} = ''; 243ok(26, $h{'foo'} eq '' ); 244 245# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. 246# This feature was reenabled in version 3.1 of Berkeley DB. 247my $result = 0 ; 248if ($null_keys_allowed) { 249 $h{''} = 'bar'; 250 $result = ( $h{''} eq 'bar' ); 251} 252else 253 { $result = 1 } 254ok(27, $result) ; 255 256# check cache overflow and numeric keys and contents 257my $ok = 1; 258for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } 259for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } 260ok(28, $ok ); 261 262($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 263 $blksize,$blocks) = stat($Dfile); 264ok(29, $size > 0 ); 265 266@h{0..200} = 200..400; 267my @foo = @h{0..200}; 268ok(30, join(':',200..400) eq join(':',@foo) ); 269 270 271# Now check all the non-tie specific stuff 272 273# Check NOOVERWRITE will make put fail when attempting to overwrite 274# an existing record. 275 276my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; 277ok(31, $status == 1 ); 278 279# check that the value of the key 'x' has not been changed by the 280# previous test 281ok(32, $h{'x'} eq 'X' ); 282 283# standard put 284$status = $X->put('key', 'value') ; 285ok(33, $status == 0 ); 286 287#check that previous put can be retrieved 288$value = 0 ; 289$status = $X->get('key', $value) ; 290ok(34, $status == 0 ); 291ok(35, $value eq 'value' ); 292 293# Attempting to delete an existing key should work 294 295$status = $X->del('q') ; 296ok(36, $status == 0 ); 297 298# Make sure that the key deleted, cannot be retrieved 299{ 300 no warnings 'uninitialized' ; 301 ok(37, $h{'q'} eq undef ); 302} 303 304# Attempting to delete a non-existant key should fail 305 306$status = $X->del('joe') ; 307ok(38, $status == 1 ); 308 309# Check the get interface 310 311# First a non-existing key 312$status = $X->get('aaaa', $value) ; 313ok(39, $status == 1 ); 314 315# Next an existing key 316$status = $X->get('a', $value) ; 317ok(40, $status == 0 ); 318ok(41, $value eq 'A' ); 319 320# seq 321# ### 322 323# ditto, but use put to replace the key/value pair. 324 325# use seq to walk backwards through a file - check that this reversed is 326 327# check seq FIRST/LAST 328 329# sync 330# #### 331 332$status = $X->sync ; 333ok(42, $status == 0 ); 334 335 336# fd 337# ## 338 339$status = $X->fd ; 340ok(43, 1 ); 341#ok(43, $status != 0 ); 342 343undef $X ; 344untie %h ; 345 346unlink $Dfile; 347 348# clear 349# ##### 350 351ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 352foreach (1 .. 10) 353 { $h{$_} = $_ * 100 } 354 355# check that there are 10 elements in the hash 356$i = 0 ; 357while (($key,$value) = each(%h)) { 358 $i++; 359} 360ok(45, $i == 10); 361 362# now clear the hash 363%h = () ; 364 365# check it is empty 366$i = 0 ; 367while (($key,$value) = each(%h)) { 368 $i++; 369} 370ok(46, $i == 0); 371 372untie %h ; 373unlink $Dfile ; 374 375 376# Now try an in memory file 377ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 378 379# fd with an in memory file should return fail 380$status = $X->fd ; 381ok(48, $status == -1 ); 382 383undef $X ; 384untie %h ; 385 386{ 387 # check ability to override the default hashing 388 my %x ; 389 my $filename = "xyz" ; 390 my $hi = new DB_File::HASHINFO ; 391 $::count = 0 ; 392 $hi->{hash} = sub { ++$::count ; length $_[0] } ; 393 ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; 394 $h{"abc"} = 123 ; 395 ok(50, $h{"abc"} == 123) ; 396 untie %x ; 397 unlink $filename ; 398 ok(51, $::count >0) ; 399} 400 401{ 402 # check that attempting to tie an array to a DB_HASH will fail 403 404 my $filename = "xyz" ; 405 my @x ; 406 eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; 407 ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; 408 unlink $filename ; 409} 410 411{ 412 # sub-class test 413 414 package Another ; 415 416 use warnings ; 417 use strict ; 418 419 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; 420 print FILE <<'EOM' ; 421 422 package SubDB ; 423 424 use warnings ; 425 use strict ; 426 our (@ISA, @EXPORT); 427 428 require Exporter ; 429 use DB_File; 430 @ISA=qw(DB_File); 431 @EXPORT = @DB_File::EXPORT ; 432 433 sub STORE { 434 my $self = shift ; 435 my $key = shift ; 436 my $value = shift ; 437 $self->SUPER::STORE($key, $value * 2) ; 438 } 439 440 sub FETCH { 441 my $self = shift ; 442 my $key = shift ; 443 $self->SUPER::FETCH($key) - 1 ; 444 } 445 446 sub put { 447 my $self = shift ; 448 my $key = shift ; 449 my $value = shift ; 450 $self->SUPER::put($key, $value * 3) ; 451 } 452 453 sub get { 454 my $self = shift ; 455 $self->SUPER::get($_[0], $_[1]) ; 456 $_[1] -= 2 ; 457 } 458 459 sub A_new_method 460 { 461 my $self = shift ; 462 my $key = shift ; 463 my $value = $self->FETCH($key) ; 464 return "[[$value]]" ; 465 } 466 467 1 ; 468EOM 469 470 close FILE ; 471 472 BEGIN { push @INC, '.'; } 473 eval 'use SubDB ; '; 474 main::ok(53, $@ eq "") ; 475 my %h ; 476 my $X ; 477 eval ' 478 $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); 479 ' ; 480 481 main::ok(54, $@ eq "") ; 482 483 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; 484 main::ok(55, $@ eq "") ; 485 main::ok(56, $ret == 5) ; 486 487 my $value = 0; 488 $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; 489 main::ok(57, $@ eq "") ; 490 main::ok(58, $ret == 10) ; 491 492 $ret = eval ' R_NEXT eq main::R_NEXT ' ; 493 main::ok(59, $@ eq "" ) ; 494 main::ok(60, $ret == 1) ; 495 496 $ret = eval '$X->A_new_method("joe") ' ; 497 main::ok(61, $@ eq "") ; 498 main::ok(62, $ret eq "[[11]]") ; 499 500 undef $X; 501 untie(%h); 502 unlink "SubDB.pm", "dbhash.tmp" ; 503 504} 505 506{ 507 # DBM Filter tests 508 use warnings ; 509 use strict ; 510 my (%h, $db) ; 511 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 512 unlink $Dfile; 513 514 sub checkOutput 515 { 516 no warnings 'uninitialized'; 517 my($fk, $sk, $fv, $sv) = @_ ; 518 519 print "# Fetch Key : expected '$fk' got '$fetch_key'\n" 520 if $fetch_key ne $fk ; 521 print "# Fetch Value : expected '$fv' got '$fetch_value'\n" 522 if $fetch_value ne $fv ; 523 print "# Store Key : expected '$sk' got '$store_key'\n" 524 if $store_key ne $sk ; 525 print "# Store Value : expected '$sv' got '$store_value'\n" 526 if $store_value ne $sv ; 527 print "# \$_ : expected 'original' got '$_'\n" 528 if $_ ne 'original' ; 529 530 return 531 $fetch_key eq $fk && $store_key eq $sk && 532 $fetch_value eq $fv && $store_value eq $sv && 533 $_ eq 'original' ; 534 } 535 536 ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 537 538 $db->filter_fetch_key (sub { $fetch_key = $_ }) ; 539 $db->filter_store_key (sub { $store_key = $_ }) ; 540 $db->filter_fetch_value (sub { $fetch_value = $_}) ; 541 $db->filter_store_value (sub { $store_value = $_ }) ; 542 543 $_ = "original" ; 544 545 $h{"fred"} = "joe" ; 546 # fk sk fv sv 547 ok(64, checkOutput( "", "fred", "", "joe")) ; 548 549 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 550 ok(65, $h{"fred"} eq "joe"); 551 # fk sk fv sv 552 ok(66, checkOutput( "", "fred", "joe", "")) ; 553 554 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 555 my ($k, $v) ; 556 $k = 'fred'; 557 ok(67, ! $db->seq($k, $v, R_FIRST) ) ; 558 ok(68, $k eq "fred") ; 559 ok(69, $v eq "joe") ; 560 # fk sk fv sv 561 ok(70, checkOutput( "fred", "fred", "joe", "")) ; 562 563 # replace the filters, but remember the previous set 564 my ($old_fk) = $db->filter_fetch_key 565 (sub { $_ = uc $_ ; $fetch_key = $_ }) ; 566 my ($old_sk) = $db->filter_store_key 567 (sub { $_ = lc $_ ; $store_key = $_ }) ; 568 my ($old_fv) = $db->filter_fetch_value 569 (sub { $_ = "[$_]"; $fetch_value = $_ }) ; 570 my ($old_sv) = $db->filter_store_value 571 (sub { s/o/x/g; $store_value = $_ }) ; 572 573 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 574 $h{"Fred"} = "Joe" ; 575 # fk sk fv sv 576 ok(71, checkOutput( "", "fred", "", "Jxe")) ; 577 578 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 579 ok(72, $h{"Fred"} eq "[Jxe]"); 580 # fk sk fv sv 581 ok(73, checkOutput( "", "fred", "[Jxe]", "")) ; 582 583 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 584 $k = 'Fred'; $v =''; 585 ok(74, ! $db->seq($k, $v, R_FIRST) ) ; 586 ok(75, $k eq "FRED") or 587 print "# k [$k]\n" ; 588 ok(76, $v eq "[Jxe]") ; 589 # fk sk fv sv 590 ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ; 591 592 # put the original filters back 593 $db->filter_fetch_key ($old_fk); 594 $db->filter_store_key ($old_sk); 595 $db->filter_fetch_value ($old_fv); 596 $db->filter_store_value ($old_sv); 597 598 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 599 $h{"fred"} = "joe" ; 600 ok(78, checkOutput( "", "fred", "", "joe")) ; 601 602 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 603 ok(79, $h{"fred"} eq "joe"); 604 ok(80, checkOutput( "", "fred", "joe", "")) ; 605 606 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 607 #ok(77, $db->FIRSTKEY() eq "fred") ; 608 $k = 'fred'; 609 ok(81, ! $db->seq($k, $v, R_FIRST) ) ; 610 ok(82, $k eq "fred") ; 611 ok(83, $v eq "joe") ; 612 # fk sk fv sv 613 ok(84, checkOutput( "fred", "fred", "joe", "")) ; 614 615 # delete the filters 616 $db->filter_fetch_key (undef); 617 $db->filter_store_key (undef); 618 $db->filter_fetch_value (undef); 619 $db->filter_store_value (undef); 620 621 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 622 $h{"fred"} = "joe" ; 623 ok(85, checkOutput( "", "", "", "")) ; 624 625 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 626 ok(86, $h{"fred"} eq "joe"); 627 ok(87, checkOutput( "", "", "", "")) ; 628 629 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 630 $k = 'fred'; 631 ok(88, ! $db->seq($k, $v, R_FIRST) ) ; 632 ok(89, $k eq "fred") ; 633 ok(90, $v eq "joe") ; 634 ok(91, checkOutput( "", "", "", "")) ; 635 636 undef $db ; 637 untie %h; 638 unlink $Dfile; 639} 640 641{ 642 # DBM Filter with a closure 643 644 use warnings ; 645 use strict ; 646 my (%h, $db) ; 647 648 unlink $Dfile; 649 ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 650 651 my %result = () ; 652 653 sub Closure 654 { 655 my ($name) = @_ ; 656 my $count = 0 ; 657 my @kept = () ; 658 659 return sub { ++$count ; 660 push @kept, $_ ; 661 $result{$name} = "$name - $count: [@kept]" ; 662 } 663 } 664 665 $db->filter_store_key(Closure("store key")) ; 666 $db->filter_store_value(Closure("store value")) ; 667 $db->filter_fetch_key(Closure("fetch key")) ; 668 $db->filter_fetch_value(Closure("fetch value")) ; 669 670 $_ = "original" ; 671 672 $h{"fred"} = "joe" ; 673 ok(93, $result{"store key"} eq "store key - 1: [fred]"); 674 ok(94, $result{"store value"} eq "store value - 1: [joe]"); 675 ok(95, ! defined $result{"fetch key"} ); 676 ok(96, ! defined $result{"fetch value"} ); 677 ok(97, $_ eq "original") ; 678 679 ok(98, $db->FIRSTKEY() eq "fred") ; 680 ok(99, $result{"store key"} eq "store key - 1: [fred]"); 681 ok(100, $result{"store value"} eq "store value - 1: [joe]"); 682 ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]"); 683 ok(102, ! defined $result{"fetch value"} ); 684 ok(103, $_ eq "original") ; 685 686 $h{"jim"} = "john" ; 687 ok(104, $result{"store key"} eq "store key - 2: [fred jim]"); 688 ok(105, $result{"store value"} eq "store value - 2: [joe john]"); 689 ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]"); 690 ok(107, ! defined $result{"fetch value"} ); 691 ok(108, $_ eq "original") ; 692 693 ok(109, $h{"fred"} eq "joe"); 694 ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]"); 695 ok(111, $result{"store value"} eq "store value - 2: [joe john]"); 696 ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]"); 697 ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]"); 698 ok(114, $_ eq "original") ; 699 700 undef $db ; 701 untie %h; 702 unlink $Dfile; 703} 704 705{ 706 # DBM Filter recursion detection 707 use warnings ; 708 use strict ; 709 my (%h, $db) ; 710 unlink $Dfile; 711 712 ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 713 714 $db->filter_store_key (sub { $_ = $h{$_} }) ; 715 716 eval '$h{1} = 1234' ; 717 ok(116, $@ =~ /^recursion detected in filter_store_key at/ ); 718 719 undef $db ; 720 untie %h; 721 unlink $Dfile; 722} 723 724 725{ 726 # Examples from the POD 727 728 my $file = "xyzt" ; 729 { 730 my $redirect = new Redirect $file ; 731 732 use warnings FATAL => qw(all); 733 use strict ; 734 use DB_File ; 735 our (%h, $k, $v); 736 737 unlink "fruit" ; 738 tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 739 or die "Cannot open file 'fruit': $!\n"; 740 741 # Add a few key/value pairs to the file 742 $h{"apple"} = "red" ; 743 $h{"orange"} = "orange" ; 744 $h{"banana"} = "yellow" ; 745 $h{"tomato"} = "red" ; 746 747 # Check for existence of a key 748 print "Banana Exists\n\n" if $h{"banana"} ; 749 750 # Delete a key/value pair. 751 delete $h{"apple"} ; 752 753 # print the contents of the file 754 while (($k, $v) = each %h) 755 { print "$k -> $v\n" } 756 757 untie %h ; 758 759 unlink "fruit" ; 760 } 761 762 ok(117, docat_del($file) eq <<'EOM') ; 763Banana Exists 764 765orange -> orange 766tomato -> red 767banana -> yellow 768EOM 769 770} 771 772{ 773 # Bug ID 20001013.009 774 # 775 # test that $hash{KEY} = undef doesn't produce the warning 776 # Use of uninitialized value in null operation 777 use warnings ; 778 use strict ; 779 use DB_File ; 780 781 unlink $Dfile; 782 my %h ; 783 my $a = ""; 784 local $SIG{__WARN__} = sub {$a = $_[0]} ; 785 786 tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; 787 $h{ABC} = undef; 788 ok(118, $a eq "") ; 789 untie %h ; 790 unlink $Dfile; 791} 792 793{ 794 # test that %hash = () doesn't produce the warning 795 # Argument "" isn't numeric in entersub 796 use warnings ; 797 use strict ; 798 use DB_File ; 799 800 unlink $Dfile; 801 my %h ; 802 my $a = ""; 803 local $SIG{__WARN__} = sub {$a = $_[0]} ; 804 805 tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; 806 %h = (); ; 807 ok(119, $a eq "") ; 808 untie %h ; 809 unlink $Dfile; 810} 811 812{ 813 # When iterating over a tied hash using "each", the key passed to FETCH 814 # will be recycled and passed to NEXTKEY. If a Source Filter modifies the 815 # key in FETCH via a filter_fetch_key method we need to check that the 816 # modified key doesn't get passed to NEXTKEY. 817 # Also Test "keys" & "values" while we are at it. 818 819 use warnings ; 820 use strict ; 821 use DB_File ; 822 823 unlink $Dfile; 824 my $bad_key = 0 ; 825 my %h = () ; 826 my $db ; 827 ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 828 $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; 829 $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; 830 831 $h{'Alpha_ABC'} = 2 ; 832 $h{'Alpha_DEF'} = 5 ; 833 834 ok(121, $h{'Alpha_ABC'} == 2); 835 ok(122, $h{'Alpha_DEF'} == 5); 836 837 my ($k, $v) = ("",""); 838 while (($k, $v) = each %h) {} 839 ok(123, $bad_key == 0); 840 841 $bad_key = 0 ; 842 foreach $k (keys %h) {} 843 ok(124, $bad_key == 0); 844 845 $bad_key = 0 ; 846 foreach $v (values %h) {} 847 ok(125, $bad_key == 0); 848 849 undef $db ; 850 untie %h ; 851 unlink $Dfile; 852} 853 854{ 855 # now an error to pass 'hash' a non-code reference 856 my $dbh = new DB_File::HASHINFO ; 857 858 eval { $dbh->{hash} = 2 }; 859 ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/); 860 861} 862 863 864#{ 865# # recursion detection in hash 866# my %hash ; 867# my $Dfile = "xxx.db"; 868# unlink $Dfile; 869# my $dbh = new DB_File::HASHINFO ; 870# $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ; 871# 872# 873# ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); 874# 875# eval { $hash{1} = 2; 876# $hash{4} = 5; 877# }; 878# 879# ok(128, $@ =~ /^DB_File hash callback: recursion detected/); 880# { 881# no warnings; 882# untie %hash; 883# } 884# unlink $Dfile; 885#} 886 887#ok(127, 1); 888#ok(128, 1); 889 890{ 891 # Check that two hash's don't interact 892 my %hash1 ; 893 my %hash2 ; 894 my $h1_count = 0; 895 my $h2_count = 0; 896 unlink $Dfile, $Dfile2; 897 my $dbh1 = new DB_File::HASHINFO ; 898 $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ; 899 900 my $dbh2 = new DB_File::HASHINFO ; 901 $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ; 902 903 904 905 my (%h); 906 ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); 907 ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); 908 909 $hash1{DEFG} = 5; 910 $hash1{XYZ} = 2; 911 $hash1{ABCDE} = 5; 912 913 $hash2{defg} = 5; 914 $hash2{xyz} = 2; 915 $hash2{abcde} = 5; 916 917 ok(129, $h1_count > 0); 918 ok(130, $h1_count == $h2_count); 919 920 ok(131, safeUntie \%hash1); 921 ok(132, safeUntie \%hash2); 922 unlink $Dfile, $Dfile2; 923} 924 925{ 926 # Passing undef for flags and/or mode when calling tie could cause 927 # Use of uninitialized value in subroutine entry 928 929 930 my $warn_count = 0 ; 931 #local $SIG{__WARN__} = sub { ++ $warn_count }; 932 my %hash1; 933 unlink $Dfile; 934 935 tie %hash1, 'DB_File',$Dfile, undef; 936 ok(133, $warn_count == 0); 937 $warn_count = 0; 938 untie %hash1; 939 unlink $Dfile; 940 tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef; 941 ok(134, $warn_count == 0); 942 untie %hash1; 943 unlink $Dfile; 944 tie %hash1, 'DB_File',$Dfile, undef, undef; 945 ok(135, $warn_count == 0); 946 $warn_count = 0; 947 948 untie %hash1; 949 unlink $Dfile; 950} 951 952{ 953 # Check that DBM Filter can cope with read-only $_ 954 955 use warnings ; 956 use strict ; 957 my (%h, $db) ; 958 my $Dfile = "xxy.db"; 959 unlink $Dfile; 960 961 ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 962 963 $db->filter_fetch_key (sub { }) ; 964 $db->filter_store_key (sub { }) ; 965 $db->filter_fetch_value (sub { }) ; 966 $db->filter_store_value (sub { }) ; 967 968 $_ = "original" ; 969 970 $h{"fred"} = "joe" ; 971 ok(137, $h{"fred"} eq "joe"); 972 973 eval { my @r= grep { $h{$_} } (1, 2, 3) }; 974 ok (138, ! $@); 975 976 977 # delete the filters 978 $db->filter_fetch_key (undef); 979 $db->filter_store_key (undef); 980 $db->filter_fetch_value (undef); 981 $db->filter_store_value (undef); 982 983 $h{"fred"} = "joe" ; 984 985 ok(139, $h{"fred"} eq "joe"); 986 987 ok(140, $db->FIRSTKEY() eq "fred") ; 988 989 eval { my @r= grep { $h{$_} } (1, 2, 3) }; 990 ok (141, ! $@); 991 992 undef $db ; 993 untie %h; 994 unlink $Dfile; 995} 996 997{ 998 # Check low-level API works with filter 999 1000 use warnings ; 1001 use strict ; 1002 my (%h, $db) ; 1003 my $Dfile = "xxy.db"; 1004 unlink $Dfile; 1005 1006 ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 1007 1008 1009 $db->filter_fetch_key (sub { $_ = unpack("i", $_) } ); 1010 $db->filter_store_key (sub { $_ = pack("i", $_) } ); 1011 $db->filter_fetch_value (sub { $_ = unpack("i", $_) } ); 1012 $db->filter_store_value (sub { $_ = pack("i", $_) } ); 1013 1014 $_ = 'fred'; 1015 1016 my $key = 22 ; 1017 my $value = 34 ; 1018 1019 $db->put($key, $value) ; 1020 ok 143, $key == 22; 1021 ok 144, $value == 34 ; 1022 ok 145, $_ eq 'fred'; 1023 #print "k [$key][$value]\n" ; 1024 1025 my $val ; 1026 $db->get($key, $val) ; 1027 ok 146, $key == 22; 1028 ok 147, $val == 34 ; 1029 ok 148, $_ eq 'fred'; 1030 1031 $key = 51 ; 1032 $value = 454; 1033 $h{$key} = $value ; 1034 ok 149, $key == 51; 1035 ok 150, $value == 454 ; 1036 ok 151, $_ eq 'fred'; 1037 1038 undef $db ; 1039 untie %h; 1040 unlink $Dfile; 1041} 1042 1043 1044{ 1045 # Regression Test for bug 30237 1046 # Check that substr can be used in the key to db_put 1047 # and that db_put does not trigger the warning 1048 # 1049 # Use of uninitialized value in subroutine entry 1050 1051 1052 use warnings ; 1053 use strict ; 1054 my (%h, $db) ; 1055 my $Dfile = "xxy.db"; 1056 unlink $Dfile; 1057 1058 ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 1059 1060 my $warned = ''; 1061 local $SIG{__WARN__} = sub {$warned = $_[0]} ; 1062 1063 # db-put with substr of key 1064 my %remember = () ; 1065 for my $ix ( 1 .. 2 ) 1066 { 1067 my $key = $ix . "data" ; 1068 my $value = "value$ix" ; 1069 $remember{$key} = $value ; 1070 $db->put(substr($key,0), $value) ; 1071 } 1072 1073 ok 153, $warned eq '' 1074 or print "# Caught warning [$warned]\n" ; 1075 1076 # db-put with substr of value 1077 $warned = ''; 1078 for my $ix ( 10 .. 12 ) 1079 { 1080 my $key = $ix . "data" ; 1081 my $value = "value$ix" ; 1082 $remember{$key} = $value ; 1083 $db->put($key, substr($value,0)) ; 1084 } 1085 1086 ok 154, $warned eq '' 1087 or print "# Caught warning [$warned]\n" ; 1088 1089 # via the tied hash is not a problem, but check anyway 1090 # substr of key 1091 $warned = ''; 1092 for my $ix ( 30 .. 32 ) 1093 { 1094 my $key = $ix . "data" ; 1095 my $value = "value$ix" ; 1096 $remember{$key} = $value ; 1097 $h{substr($key,0)} = $value ; 1098 } 1099 1100 ok 155, $warned eq '' 1101 or print "# Caught warning [$warned]\n" ; 1102 1103 # via the tied hash is not a problem, but check anyway 1104 # substr of value 1105 $warned = ''; 1106 for my $ix ( 40 .. 42 ) 1107 { 1108 my $key = $ix . "data" ; 1109 my $value = "value$ix" ; 1110 $remember{$key} = $value ; 1111 $h{$key} = substr($value,0) ; 1112 } 1113 1114 ok 156, $warned eq '' 1115 or print "# Caught warning [$warned]\n" ; 1116 1117 my %bad = () ; 1118 $key = ''; 1119 for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ; 1120 $status == 0 ; 1121 $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) { 1122 1123 #print "# key [$key] value [$value]\n" ; 1124 if (defined $remember{$key} && defined $value && 1125 $remember{$key} eq $value) { 1126 delete $remember{$key} ; 1127 } 1128 else { 1129 $bad{$key} = $value ; 1130 } 1131 } 1132 1133 ok 157, keys %bad == 0 ; 1134 ok 158, keys %remember == 0 ; 1135 1136 print "# missing -- $key=>$value\n" while ($key, $value) = each %remember; 1137 print "# bad -- $key=>$value\n" while ($key, $value) = each %bad; 1138 1139 # Make sure this fix does not break code to handle an undef key 1140 # Berkeley DB undef key is broken between versions 2.3.16 and 3.1 1141 my $value = 'fred'; 1142 $warned = ''; 1143 $db->put(undef, $value) ; 1144 ok 159, $warned eq '' 1145 or print "# Caught warning [$warned]\n" ; 1146 $warned = ''; 1147 1148 my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ; 1149 print "# db_ver $DB_File::db_ver\n"; 1150 $value = '' ; 1151 $db->get(undef, $value) ; 1152 ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ; 1153 ok 161, $warned eq '' 1154 or print "# Caught warning [$warned]\n" ; 1155 $warned = ''; 1156 1157 undef $db ; 1158 untie %h; 1159 unlink $Dfile; 1160} 1161 1162{ 1163 # Check filter + substr 1164 1165 use warnings ; 1166 use strict ; 1167 my (%h, $db) ; 1168 my $Dfile = "xxy.db"; 1169 unlink $Dfile; 1170 1171 ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); 1172 1173 1174 { 1175 $db->filter_fetch_key (sub { lc $_ } ); 1176 $db->filter_store_key (sub { uc $_ } ); 1177 $db->filter_fetch_value (sub { lc $_ } ); 1178 $db->filter_store_value (sub { uc $_ } ); 1179 } 1180 1181 $_ = 'fred'; 1182 1183 # db-put with substr of key 1184 my %remember = () ; 1185 my $status = 0 ; 1186 for my $ix ( 1 .. 2 ) 1187 { 1188 my $key = $ix . "data" ; 1189 my $value = "value$ix" ; 1190 $remember{$key} = $value ; 1191 $status += $db->put(substr($key,0), substr($value,0)) ; 1192 } 1193 1194 ok 163, $status == 0 or print "# Status $status\n" ; 1195 1196 if (1) 1197 { 1198 $db->filter_fetch_key (undef); 1199 $db->filter_store_key (undef); 1200 $db->filter_fetch_value (undef); 1201 $db->filter_store_value (undef); 1202 } 1203 1204 my %bad = () ; 1205 my $key = ''; 1206 my $value = ''; 1207 for ($status = $db->seq($key, $value, R_FIRST ) ; 1208 $status == 0 ; 1209 $status = $db->seq($key, $value, R_NEXT ) ) { 1210 1211 #print "# key [$key] value [$value]\n" ; 1212 if (defined $remember{$key} && defined $value && 1213 $remember{$key} eq $value) { 1214 delete $remember{$key} ; 1215 } 1216 else { 1217 $bad{$key} = $value ; 1218 } 1219 } 1220 1221 ok 164, $_ eq 'fred'; 1222 ok 165, keys %bad == 0 ; 1223 ok 166, keys %remember == 0 ; 1224 1225 print "# missing -- $key $value\n" while ($key, $value) = each %remember; 1226 print "# bad -- $key $value\n" while ($key, $value) = each %bad; 1227 undef $db ; 1228 untie %h; 1229 unlink $Dfile; 1230} 1231 1232exit ; 1233