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..166\n";
  27
  28 unlink glob "__db.*";
  29
  30 sub 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
  63 sub 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
  75 sub normalise
  76 {
  77     my $data = shift ;
  78     $data =~ s#\r\n#\n#g
  79         if $^O eq 'cygwin' ;
  80     return $data ;
  81 }
  82
  83 sub 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
  93 my $Dfile = "dbhash.tmp";
  94 my $Dfile2 = "dbhash2.tmp";
  95 my $null_keys_allowed = ($DB_File::db_ver < 2.004010
  96                                 || $DB_File::db_ver >= 3.1 );
  97
  98 unlink $Dfile;
  99
 100 umask(0);
 101
 102 # Check the interface to HASHINFO
 103
 104 my $dbh = new DB_File::HASHINFO ;
 105
 106 ok(1, ! defined $dbh->{bsize}) ;
 107 ok(2, ! defined $dbh->{ffactor}) ;
 108 ok(3, ! defined $dbh->{nelem}) ;
 109 ok(4, ! defined $dbh->{cachesize}) ;
 110 ok(5, ! defined $dbh->{hash}) ;
 111 ok(6, ! defined $dbh->{lorder}) ;
 112
 113 $dbh->{bsize} = 3000 ;
 114 ok(7, $dbh->{bsize} == 3000 );
 115
 116 $dbh->{ffactor} = 9000 ;
 117 ok(8, $dbh->{ffactor} == 9000 );
 118
 119 $dbh->{nelem} = 400 ;
 120 ok(9, $dbh->{nelem} == 400 );
 121
 122 $dbh->{cachesize} = 65 ;
 123 ok(10, $dbh->{cachesize} == 65 );
 124
 125 my $some_sub = sub {} ;
 126 $dbh->{hash} = $some_sub;
 127 ok(11, $dbh->{hash} eq $some_sub );
 128
 129 $dbh->{lorder} = 1234 ;
 130 ok(12, $dbh->{lorder} == 1234 );
 131
 132 # Check that an invalid entry is caught both for store & fetch
 133 eval '$dbh->{fred} = 1234' ;
 134 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
 135 eval 'my $q = $dbh->{fred}' ;
 136 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
 137
 138
 139 # Now check the interface to HASH
 140 my ($X, %h);
 141 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 142 die "Could not tie: $!" unless $X;
 143
 144 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 145    $blksize,$blocks) = stat($Dfile);
 146
 147 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 148
 149 ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
 150    $noMode{$^O} );
 151
 152 my ($key, $value, $i);
 153 while (($key,$value) = each(%h)) {
 154     $i++;
 155 }
 156 ok(17, !$i );
 157
 158 $h{'goner1'} = 'snork';
 159
 160 $h{'abc'} = 'ABC';
 161 ok(18, $h{'abc'} eq 'ABC' );
 162 ok(19, !defined $h{'jimmy'} );
 163 ok(20, !exists $h{'jimmy'} );
 164 ok(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';
 186 delete $h{'goner2'};
 187
 188
 189 # IMPORTANT - $X must be undefined before the untie otherwise the
 190 #             underlying DB close routine will not get called.
 191 undef $X ;
 192 untie(%h);
 193
 194
 195 # tie to the same file again, do not supply a type - should default to HASH
 196 ok(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
 221 delete $h{'goner1'};
 222 $X->DELETE('goner3');
 223
 224 my @keys = keys(%h);
 225 my @values = values(%h);
 226
 227 ok(23, $#keys == 29 && $#values == 29) ;
 228
 229 $i = 0 ;
 230 while (($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
 237 ok(24, $i == 30) ;
 238
 239 @keys = ('blurfl', keys(%h), 'dyick');
 240 ok(25, $#keys == 31) ;
 241
 242 $h{'foo'} = '';
 243 ok(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.
 247 my $result = 0 ;
 248 if ($null_keys_allowed) {
 249     $h{''} = 'bar';
 250     $result = ( $h{''} eq 'bar' );
 251 }
 252 else
 253   { $result = 1 }
 254 ok(27, $result) ;
 255
 256 # check cache overflow and numeric keys and contents
 257 my $ok = 1;
 258 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 259 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 260 ok(28, $ok );
 261
 262 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 263    $blksize,$blocks) = stat($Dfile);
 264 ok(29, $size > 0 );
 265
 266 @h{0..200} = 200..400;
 267 my @foo = @h{0..200};
 268 ok(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
 276 my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 277 ok(31, $status == 1 );
 278
 279 # check that the value of the key 'x' has not been changed by the
 280 # previous test
 281 ok(32, $h{'x'} eq 'X' );
 282
 283 # standard put
 284 $status = $X->put('key', 'value') ;
 285 ok(33, $status == 0 );
 286
 287 #check that previous put can be retrieved
 288 $value = 0 ;
 289 $status = $X->get('key', $value) ;
 290 ok(34, $status == 0 );
 291 ok(35, $value eq 'value' );
 292
 293 # Attempting to delete an existing key should work
 294
 295 $status = $X->del('q') ;
 296 ok(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') ;
 307 ok(38, $status == 1 );
 308
 309 # Check the get interface
 310
 311 # First a non-existing key
 312 $status = $X->get('aaaa', $value) ;
 313 ok(39, $status == 1 );
 314
 315 # Next an existing key
 316 $status = $X->get('a', $value) ;
 317 ok(40, $status == 0 );
 318 ok(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 ;
 333 ok(42, $status == 0 );
 334
 335
 336 # fd
 337 # ##
 338
 339 $status = $X->fd ;
 340 ok(43, 1 );
 341 #ok(43, $status != 0 );
 342
 343 undef $X ;
 344 untie %h ;
 345
 346 unlink $Dfile;
 347
 348 # clear
 349 # #####
 350
 351 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 352 foreach (1 .. 10)
 353   { $h{$_} = $_ * 100 }
 354
 355 # check that there are 10 elements in the hash
 356 $i = 0 ;
 357 while (($key,$value) = each(%h)) {
 358     $i++;
 359 }
 360 ok(45, $i == 10);
 361
 362 # now clear the hash
 363 %h = () ;
 364
 365 # check it is empty
 366 $i = 0 ;
 367 while (($key,$value) = each(%h)) {
 368     $i++;
 369 }
 370 ok(46, $i == 0);
 371
 372 untie %h ;
 373 unlink $Dfile ;
 374
 375
 376 # Now try an in memory file
 377 ok(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 ;
 381 ok(48, $status == -1 );
 382
 383 undef $X ;
 384 untie %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 ;
 468 EOM
 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') ;
 763 Banana Exists
 764
 765 orange -> orange
 766 tomato -> red
 767 banana -> yellow
 768 EOM
 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 { 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 { 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
1232 exit ;