ext/DB_File/t/db-hash.t

   1 #!./perl
   2
   3 use warnings ;
   4 use strict ;
   5
   6 BEGIN {
   7     unless(grep /blib/, @INC) {
   8         chdir 't' if -d 't';
   9         @INC = '../lib' if -d '../lib';
  10     }
  11 }
  12
  13 use Config;
  14
  15 BEGIN {
  16     if(-d "lib" && -f "TEST") {
  17         if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
  18             print "1..111\n";
  19             exit 0;
  20         }
  21     }
  22 }
  23
  24 use strict;
  25 use warnings;
  26 use DB_File;
  27 use Fcntl;
  28
  29 print "1..117\n";
  30
  31 sub ok
  32 {
  33     my $no = shift ;
  34     my $result = shift ;
  35
  36     print "not " unless $result ;
  37     print "ok $no\n" ;
  38 }
  39
  40 {
  41     package Redirect ;
  42     use Symbol ;
  43
  44     sub new
  45     {
  46         my $class = shift ;
  47         my $filename = shift ;
  48         my $fh = gensym ;
  49         open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  50         my $real_stdout = select($fh) ;
  51         return bless [$fh, $real_stdout ] ;
  52
  53     }
  54     sub DESTROY
  55     {
  56         my $self = shift ;
  57         close $self->[0] ;
  58         select($self->[1]) ;
  59     }
  60 }
  61
  62 sub docat_del
  63 {
  64     my $file = shift;
  65     local $/ = undef;
  66     open(CAT,$file) || die "Cannot open $file: $!";
  67     my $result = <CAT>;
  68     close(CAT);
  69     $result = normalise($result) ;
  70     unlink $file ;
  71     return $result;
  72 }
  73
  74 sub normalise
  75 {
  76     my $data = shift ;
  77     $data =~ s#\r\n#\n#g
  78         if $^O eq 'cygwin' ;
  79     return $data ;
  80 }
  81
  82
  83
  84 my $Dfile = "dbhash.tmp";
  85 my $null_keys_allowed = ($DB_File::db_ver < 2.004010
  86                                 || $DB_File::db_ver >= 3.1 );
  87
  88 unlink $Dfile;
  89
  90 umask(0);
  91
  92 # Check the interface to HASHINFO
  93
  94 my $dbh = new DB_File::HASHINFO ;
  95
  96 ok(1, ! defined $dbh->{bsize}) ;
  97 ok(2, ! defined $dbh->{ffactor}) ;
  98 ok(3, ! defined $dbh->{nelem}) ;
  99 ok(4, ! defined $dbh->{cachesize}) ;
 100 ok(5, ! defined $dbh->{hash}) ;
 101 ok(6, ! defined $dbh->{lorder}) ;
 102
 103 $dbh->{bsize} = 3000 ;
 104 ok(7, $dbh->{bsize} == 3000 );
 105
 106 $dbh->{ffactor} = 9000 ;
 107 ok(8, $dbh->{ffactor} == 9000 );
 108
 109 $dbh->{nelem} = 400 ;
 110 ok(9, $dbh->{nelem} == 400 );
 111
 112 $dbh->{cachesize} = 65 ;
 113 ok(10, $dbh->{cachesize} == 65 );
 114
 115 $dbh->{hash} = "abc" ;
 116 ok(11, $dbh->{hash} eq "abc" );
 117
 118 $dbh->{lorder} = 1234 ;
 119 ok(12, $dbh->{lorder} == 1234 );
 120
 121 # Check that an invalid entry is caught both for store & fetch
 122 eval '$dbh->{fred} = 1234' ;
 123 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
 124 eval 'my $q = $dbh->{fred}' ;
 125 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
 126
 127
 128 # Now check the interface to HASH
 129 my ($X, %h);
 130 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 131
 132 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 133    $blksize,$blocks) = stat($Dfile);
 134
 135 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 136
 137 ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
 138    $noMode{$^O} );
 139
 140 my ($key, $value, $i);
 141 while (($key,$value) = each(%h)) {
 142     $i++;
 143 }
 144 ok(17, !$i );
 145
 146 $h{'goner1'} = 'snork';
 147
 148 $h{'abc'} = 'ABC';
 149 ok(18, $h{'abc'} eq 'ABC' );
 150 ok(19, !defined $h{'jimmy'} );
 151 ok(20, !exists $h{'jimmy'} );
 152 ok(21, exists $h{'abc'} );
 153
 154 $h{'def'} = 'DEF';
 155 $h{'jkl','mno'} = "JKL\034MNO";
 156 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
 157 $h{'a'} = 'A';
 158
 159 #$h{'b'} = 'B';
 160 $X->STORE('b', 'B') ;
 161
 162 $h{'c'} = 'C';
 163
 164 #$h{'d'} = 'D';
 165 $X->put('d', 'D') ;
 166
 167 $h{'e'} = 'E';
 168 $h{'f'} = 'F';
 169 $h{'g'} = 'X';
 170 $h{'h'} = 'H';
 171 $h{'i'} = 'I';
 172
 173 $h{'goner2'} = 'snork';
 174 delete $h{'goner2'};
 175
 176
 177 # IMPORTANT - $X must be undefined before the untie otherwise the
 178 #             underlying DB close routine will not get called.
 179 undef $X ;
 180 untie(%h);
 181
 182
 183 # tie to the same file again, do not supply a type - should default to HASH
 184 ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
 185
 186 # Modify an entry from the previous tie
 187 $h{'g'} = 'G';
 188
 189 $h{'j'} = 'J';
 190 $h{'k'} = 'K';
 191 $h{'l'} = 'L';
 192 $h{'m'} = 'M';
 193 $h{'n'} = 'N';
 194 $h{'o'} = 'O';
 195 $h{'p'} = 'P';
 196 $h{'q'} = 'Q';
 197 $h{'r'} = 'R';
 198 $h{'s'} = 'S';
 199 $h{'t'} = 'T';
 200 $h{'u'} = 'U';
 201 $h{'v'} = 'V';
 202 $h{'w'} = 'W';
 203 $h{'x'} = 'X';
 204 $h{'y'} = 'Y';
 205 $h{'z'} = 'Z';
 206
 207 $h{'goner3'} = 'snork';
 208
 209 delete $h{'goner1'};
 210 $X->DELETE('goner3');
 211
 212 my @keys = keys(%h);
 213 my @values = values(%h);
 214
 215 ok(23, $#keys == 29 && $#values == 29) ;
 216
 217 $i = 0 ;
 218 while (($key,$value) = each(%h)) {
 219     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 220         $key =~ y/a-z/A-Z/;
 221         $i++ if $key eq $value;
 222     }
 223 }
 224
 225 ok(24, $i == 30) ;
 226
 227 @keys = ('blurfl', keys(%h), 'dyick');
 228 ok(25, $#keys == 31) ;
 229
 230 $h{'foo'} = '';
 231 ok(26, $h{'foo'} eq '' );
 232
 233 # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
 234 # This feature was reenabled in version 3.1 of Berkeley DB.
 235 my $result = 0 ;
 236 if ($null_keys_allowed) {
 237     $h{''} = 'bar';
 238     $result = ( $h{''} eq 'bar' );
 239 }
 240 else
 241   { $result = 1 }
 242 ok(27, $result) ;
 243
 244 # check cache overflow and numeric keys and contents
 245 my $ok = 1;
 246 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 247 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 248 ok(28, $ok );
 249
 250 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 251    $blksize,$blocks) = stat($Dfile);
 252 ok(29, $size > 0 );
 253
 254 @h{0..200} = 200..400;
 255 my @foo = @h{0..200};
 256 ok(30, join(':',200..400) eq join(':',@foo) );
 257
 258
 259 # Now check all the non-tie specific stuff
 260
 261 # Check NOOVERWRITE will make put fail when attempting to overwrite
 262 # an existing record.
 263
 264 my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 265 ok(31, $status == 1 );
 266
 267 # check that the value of the key 'x' has not been changed by the
 268 # previous test
 269 ok(32, $h{'x'} eq 'X' );
 270
 271 # standard put
 272 $status = $X->put('key', 'value') ;
 273 ok(33, $status == 0 );
 274
 275 #check that previous put can be retrieved
 276 $value = 0 ;
 277 $status = $X->get('key', $value) ;
 278 ok(34, $status == 0 );
 279 ok(35, $value eq 'value' );
 280
 281 # Attempting to delete an existing key should work
 282
 283 $status = $X->del('q') ;
 284 ok(36, $status == 0 );
 285
 286 # Make sure that the key deleted, cannot be retrieved
 287 {
 288     no warnings 'uninitialized' ;
 289     ok(37, $h{'q'} eq undef );
 290 }
 291
 292 # Attempting to delete a non-existant key should fail
 293
 294 $status = $X->del('joe') ;
 295 ok(38, $status == 1 );
 296
 297 # Check the get interface
 298
 299 # First a non-existing key
 300 $status = $X->get('aaaa', $value) ;
 301 ok(39, $status == 1 );
 302
 303 # Next an existing key
 304 $status = $X->get('a', $value) ;
 305 ok(40, $status == 0 );
 306 ok(41, $value eq 'A' );
 307
 308 # seq
 309 # ###
 310
 311 # ditto, but use put to replace the key/value pair.
 312
 313 # use seq to walk backwards through a file - check that this reversed is
 314
 315 # check seq FIRST/LAST
 316
 317 # sync
 318 # ####
 319
 320 $status = $X->sync ;
 321 ok(42, $status == 0 );
 322
 323
 324 # fd
 325 # ##
 326
 327 $status = $X->fd ;
 328 ok(43, $status != 0 );
 329
 330 undef $X ;
 331 untie %h ;
 332
 333 unlink $Dfile;
 334
 335 # clear
 336 # #####
 337
 338 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 339 foreach (1 .. 10)
 340   { $h{$_} = $_ * 100 }
 341
 342 # check that there are 10 elements in the hash
 343 $i = 0 ;
 344 while (($key,$value) = each(%h)) {
 345     $i++;
 346 }
 347 ok(45, $i == 10);
 348
 349 # now clear the hash
 350 %h = () ;
 351
 352 # check it is empty
 353 $i = 0 ;
 354 while (($key,$value) = each(%h)) {
 355     $i++;
 356 }
 357 ok(46, $i == 0);
 358
 359 untie %h ;
 360 unlink $Dfile ;
 361
 362
 363 # Now try an in memory file
 364 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 365
 366 # fd with an in memory file should return fail
 367 $status = $X->fd ;
 368 ok(48, $status == -1 );
 369
 370 undef $X ;
 371 untie %h ;
 372
 373 {
 374     # check ability to override the default hashing
 375     my %x ;
 376     my $filename = "xyz" ;
 377     my $hi = new DB_File::HASHINFO ;
 378     $::count = 0 ;
 379     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 380     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 381     $h{"abc"} = 123 ;
 382     ok(50, $h{"abc"} == 123) ;
 383     untie %x ;
 384     unlink $filename ;
 385     ok(51, $::count >0) ;
 386 }
 387
 388 {
 389     # check that attempting to tie an array to a DB_HASH will fail
 390
 391     my $filename = "xyz" ;
 392     my @x ;
 393     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
 394     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
 395     unlink $filename ;
 396 }
 397
 398 {
 399    # sub-class test
 400
 401    package Another ;
 402
 403    use warnings ;
 404    use strict ;
 405
 406    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 407    print FILE <<'EOM' ;
 408
 409    package SubDB ;
 410
 411    use warnings ;
 412    use strict ;
 413    use vars qw( @ISA @EXPORT) ;
 414
 415    require Exporter ;
 416    use DB_File;
 417    @ISA=qw(DB_File);
 418    @EXPORT = @DB_File::EXPORT ;
 419
 420    sub STORE {
 421         my $self = shift ;
 422         my $key = shift ;
 423         my $value = shift ;
 424         $self->SUPER::STORE($key, $value * 2) ;
 425    }
 426
 427    sub FETCH {
 428         my $self = shift ;
 429         my $key = shift ;
 430         $self->SUPER::FETCH($key) - 1 ;
 431    }
 432
 433    sub put {
 434         my $self = shift ;
 435         my $key = shift ;
 436         my $value = shift ;
 437         $self->SUPER::put($key, $value * 3) ;
 438    }
 439
 440    sub get {
 441         my $self = shift ;
 442         $self->SUPER::get($_[0], $_[1]) ;
 443         $_[1] -= 2 ;
 444    }
 445
 446    sub A_new_method
 447    {
 448         my $self = shift ;
 449         my $key = shift ;
 450         my $value = $self->FETCH($key) ;
 451         return "[[$value]]" ;
 452    }
 453
 454    1 ;
 455 EOM
 456
 457     close FILE ;
 458
 459     BEGIN { push @INC, '.'; }
 460     eval 'use SubDB ; ';
 461     main::ok(53, $@ eq "") ;
 462     my %h ;
 463     my $X ;
 464     eval '
 465         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
 466         ' ;
 467
 468     main::ok(54, $@ eq "") ;
 469
 470     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 471     main::ok(55, $@ eq "") ;
 472     main::ok(56, $ret == 5) ;
 473
 474     my $value = 0;
 475     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 476     main::ok(57, $@ eq "") ;
 477     main::ok(58, $ret == 10) ;
 478
 479     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 480     main::ok(59, $@ eq "" ) ;
 481     main::ok(60, $ret == 1) ;
 482
 483     $ret = eval '$X->A_new_method("joe") ' ;
 484     main::ok(61, $@ eq "") ;
 485     main::ok(62, $ret eq "[[11]]") ;
 486
 487     undef $X;
 488     untie(%h);
 489     unlink "SubDB.pm", "dbhash.tmp" ;
 490
 491 }
 492
 493 {
 494    # DBM Filter tests
 495    use warnings ;
 496    use strict ;
 497    my (%h, $db) ;
 498    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 499    unlink $Dfile;
 500
 501    sub checkOutput
 502    {
 503        my($fk, $sk, $fv, $sv) = @_ ;
 504        return
 505            $fetch_key eq $fk && $store_key eq $sk &&
 506            $fetch_value eq $fv && $store_value eq $sv &&
 507            $_ eq 'original' ;
 508    }
 509
 510    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 511
 512    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 513    $db->filter_store_key   (sub { $store_key = $_ }) ;
 514    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 515    $db->filter_store_value (sub { $store_value = $_ }) ;
 516
 517    $_ = "original" ;
 518
 519    $h{"fred"} = "joe" ;
 520    #                   fk   sk     fv   sv
 521    ok(64, checkOutput( "", "fred", "", "joe")) ;
 522
 523    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 524    ok(65, $h{"fred"} eq "joe");
 525    #                   fk    sk     fv    sv
 526    ok(66, checkOutput( "", "fred", "joe", "")) ;
 527
 528    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 529    ok(67, $db->FIRSTKEY() eq "fred") ;
 530    #                    fk     sk  fv  sv
 531    ok(68, checkOutput( "fred", "", "", "")) ;
 532
 533    # replace the filters, but remember the previous set
 534    my ($old_fk) = $db->filter_fetch_key
 535                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 536    my ($old_sk) = $db->filter_store_key
 537                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 538    my ($old_fv) = $db->filter_fetch_value
 539                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 540    my ($old_sv) = $db->filter_store_value
 541                         (sub { s/o/x/g; $store_value = $_ }) ;
 542
 543    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 544    $h{"Fred"} = "Joe" ;
 545    #                   fk   sk     fv    sv
 546    ok(69, checkOutput( "", "fred", "", "Jxe")) ;
 547
 548    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 549    ok(70, $h{"Fred"} eq "[Jxe]");
 550    #                   fk   sk     fv    sv
 551    ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
 552
 553    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 554    ok(72, $db->FIRSTKEY() eq "FRED") ;
 555    #                   fk   sk     fv    sv
 556    ok(73, checkOutput( "FRED", "", "", "")) ;
 557
 558    # put the original filters back
 559    $db->filter_fetch_key   ($old_fk);
 560    $db->filter_store_key   ($old_sk);
 561    $db->filter_fetch_value ($old_fv);
 562    $db->filter_store_value ($old_sv);
 563
 564    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 565    $h{"fred"} = "joe" ;
 566    ok(74, checkOutput( "", "fred", "", "joe")) ;
 567
 568    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 569    ok(75, $h{"fred"} eq "joe");
 570    ok(76, checkOutput( "", "fred", "joe", "")) ;
 571
 572    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 573    ok(77, $db->FIRSTKEY() eq "fred") ;
 574    ok(78, checkOutput( "fred", "", "", "")) ;
 575
 576    # delete the filters
 577    $db->filter_fetch_key   (undef);
 578    $db->filter_store_key   (undef);
 579    $db->filter_fetch_value (undef);
 580    $db->filter_store_value (undef);
 581
 582    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 583    $h{"fred"} = "joe" ;
 584    ok(79, checkOutput( "", "", "", "")) ;
 585
 586    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 587    ok(80, $h{"fred"} eq "joe");
 588    ok(81, checkOutput( "", "", "", "")) ;
 589
 590    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 591    ok(82, $db->FIRSTKEY() eq "fred") ;
 592    ok(83, checkOutput( "", "", "", "")) ;
 593
 594    undef $db ;
 595    untie %h;
 596    unlink $Dfile;
 597 }
 598
 599 {
 600     # DBM Filter with a closure
 601
 602     use warnings ;
 603     use strict ;
 604     my (%h, $db) ;
 605
 606     unlink $Dfile;
 607     ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 608
 609     my %result = () ;
 610
 611     sub Closure
 612     {
 613         my ($name) = @_ ;
 614         my $count = 0 ;
 615         my @kept = () ;
 616
 617         return sub { ++$count ;
 618                      push @kept, $_ ;
 619                      $result{$name} = "$name - $count: [@kept]" ;
 620                    }
 621     }
 622
 623     $db->filter_store_key(Closure("store key")) ;
 624     $db->filter_store_value(Closure("store value")) ;
 625     $db->filter_fetch_key(Closure("fetch key")) ;
 626     $db->filter_fetch_value(Closure("fetch value")) ;
 627
 628     $_ = "original" ;
 629
 630     $h{"fred"} = "joe" ;
 631     ok(85, $result{"store key"} eq "store key - 1: [fred]");
 632     ok(86, $result{"store value"} eq "store value - 1: [joe]");
 633     ok(87, ! defined $result{"fetch key"} );
 634     ok(88, ! defined $result{"fetch value"} );
 635     ok(89, $_ eq "original") ;
 636
 637     ok(90, $db->FIRSTKEY() eq "fred") ;
 638     ok(91, $result{"store key"} eq "store key - 1: [fred]");
 639     ok(92, $result{"store value"} eq "store value - 1: [joe]");
 640     ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
 641     ok(94, ! defined $result{"fetch value"} );
 642     ok(95, $_ eq "original") ;
 643
 644     $h{"jim"}  = "john" ;
 645     ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
 646     ok(97, $result{"store value"} eq "store value - 2: [joe john]");
 647     ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
 648     ok(99, ! defined $result{"fetch value"} );
 649     ok(100, $_ eq "original") ;
 650
 651     ok(101, $h{"fred"} eq "joe");
 652     ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
 653     ok(103, $result{"store value"} eq "store value - 2: [joe john]");
 654     ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
 655     ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
 656     ok(106, $_ eq "original") ;
 657
 658     undef $db ;
 659     untie %h;
 660     unlink $Dfile;
 661 }
 662
 663 {
 664    # DBM Filter recursion detection
 665    use warnings ;
 666    use strict ;
 667    my (%h, $db) ;
 668    unlink $Dfile;
 669
 670    ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 671
 672    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 673
 674    eval '$h{1} = 1234' ;
 675    ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
 676
 677    undef $db ;
 678    untie %h;
 679    unlink $Dfile;
 680 }
 681
 682
 683 {
 684    # Examples from the POD
 685
 686   my $file = "xyzt" ;
 687   {
 688     my $redirect = new Redirect $file ;
 689
 690     use warnings FATAL => qw(all);
 691     use strict ;
 692     use DB_File ;
 693     use vars qw( %h $k $v ) ;
 694
 695     unlink "fruit" ;
 696     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
 697         or die "Cannot open file 'fruit': $!\n";
 698
 699     # Add a few key/value pairs to the file
 700     $h{"apple"} = "red" ;
 701     $h{"orange"} = "orange" ;
 702     $h{"banana"} = "yellow" ;
 703     $h{"tomato"} = "red" ;
 704
 705     # Check for existence of a key
 706     print "Banana Exists\n\n" if $h{"banana"} ;
 707
 708     # Delete a key/value pair.
 709     delete $h{"apple"} ;
 710
 711     # print the contents of the file
 712     while (($k, $v) = each %h)
 713       { print "$k -> $v\n" }
 714
 715     untie %h ;
 716
 717     unlink "fruit" ;
 718   }
 719
 720   ok(109, docat_del($file) eq <<'EOM') ;
 721 Banana Exists
 722
 723 orange -> orange
 724 tomato -> red
 725 banana -> yellow
 726 EOM
 727
 728 }
 729
 730 {
 731     # Bug ID 20001013.009
 732     #
 733     # test that $hash{KEY} = undef doesn't produce the warning
 734     #     Use of uninitialized value in null operation
 735     use warnings ;
 736     use strict ;
 737     use DB_File ;
 738
 739     unlink $Dfile;
 740     my %h ;
 741     my $a = "";
 742     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 743
 744     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 745     $h{ABC} = undef;
 746     ok(110, $a eq "") ;
 747     untie %h ;
 748     unlink $Dfile;
 749 }
 750
 751 {
 752     # test that %hash = () doesn't produce the warning
 753     #     Argument "" isn't numeric in entersub
 754     use warnings ;
 755     use strict ;
 756     use DB_File ;
 757
 758     unlink $Dfile;
 759     my %h ;
 760     my $a = "";
 761     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 762
 763     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 764     %h = (); ;
 765     ok(111, $a eq "") ;
 766     untie %h ;
 767     unlink $Dfile;
 768 }
 769
 770 {
 771     # When iterating over a tied hash using "each", the key passed to FETCH
 772     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
 773     # key in FETCH via a filter_fetch_key method we need to check that the
 774     # modified key doesn't get passed to NEXTKEY.
 775     # Also Test "keys" & "values" while we are at it.
 776
 777     use warnings ;
 778     use strict ;
 779     use DB_File ;
 780
 781     unlink $Dfile;
 782     my $bad_key = 0 ;
 783     my %h = () ;
 784     my $db ;
 785     ok(112, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 786     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
 787     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
 788
 789     $h{'Alpha_ABC'} = 2 ;
 790     $h{'Alpha_DEF'} = 5 ;
 791
 792     ok(113, $h{'Alpha_ABC'} == 2);
 793     ok(114, $h{'Alpha_DEF'} == 5);
 794
 795     my ($k, $v) = ("","");
 796     while (($k, $v) = each %h) {}
 797     ok(115, $bad_key == 0);
 798
 799     $bad_key = 0 ;
 800     foreach $k (keys %h) {}
 801     ok(116, $bad_key == 0);
 802
 803     $bad_key = 0 ;
 804     foreach $v (values %h) {}
 805     ok(117, $bad_key == 0);
 806
 807     undef $db ;
 808     untie %h ;
 809     unlink $Dfile;
 810 }
 811
 812 exit ;