ext/DB_File/t/db-hash.t

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