ext/DB_File/t/db-hash.t

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