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..161\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, $status != 0 );
 341
 342 undef $X ;
 343 untie %h ;
 344
 345 unlink $Dfile;
 346
 347 # clear
 348 # #####
 349
 350 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 351 foreach (1 .. 10)
 352   { $h{$_} = $_ * 100 }
 353
 354 # check that there are 10 elements in the hash
 355 $i = 0 ;
 356 while (($key,$value) = each(%h)) {
 357     $i++;
 358 }
 359 ok(45, $i == 10);
 360
 361 # now clear the hash
 362 %h = () ;
 363
 364 # check it is empty
 365 $i = 0 ;
 366 while (($key,$value) = each(%h)) {
 367     $i++;
 368 }
 369 ok(46, $i == 0);
 370
 371 untie %h ;
 372 unlink $Dfile ;
 373
 374
 375 # Now try an in memory file
 376 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 377
 378 # fd with an in memory file should return fail
 379 $status = $X->fd ;
 380 ok(48, $status == -1 );
 381
 382 undef $X ;
 383 untie %h ;
 384
 385 {
 386     # check ability to override the default hashing
 387     my %x ;
 388     my $filename = "xyz" ;
 389     my $hi = new DB_File::HASHINFO ;
 390     $::count = 0 ;
 391     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 392     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 393     $h{"abc"} = 123 ;
 394     ok(50, $h{"abc"} == 123) ;
 395     untie %x ;
 396     unlink $filename ;
 397     ok(51, $::count >0) ;
 398 }
 399
 400 {
 401     # check that attempting to tie an array to a DB_HASH will fail
 402
 403     my $filename = "xyz" ;
 404     my @x ;
 405     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
 406     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
 407     unlink $filename ;
 408 }
 409
 410 {
 411    # sub-class test
 412
 413    package Another ;
 414
 415    use warnings ;
 416    use strict ;
 417
 418    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 419    print FILE <<'EOM' ;
 420
 421    package SubDB ;
 422
 423    use warnings ;
 424    use strict ;
 425    our (@ISA, @EXPORT);
 426
 427    require Exporter ;
 428    use DB_File;
 429    @ISA=qw(DB_File);
 430    @EXPORT = @DB_File::EXPORT ;
 431
 432    sub STORE {
 433         my $self = shift ;
 434         my $key = shift ;
 435         my $value = shift ;
 436         $self->SUPER::STORE($key, $value * 2) ;
 437    }
 438
 439    sub FETCH {
 440         my $self = shift ;
 441         my $key = shift ;
 442         $self->SUPER::FETCH($key) - 1 ;
 443    }
 444
 445    sub put {
 446         my $self = shift ;
 447         my $key = shift ;
 448         my $value = shift ;
 449         $self->SUPER::put($key, $value * 3) ;
 450    }
 451
 452    sub get {
 453         my $self = shift ;
 454         $self->SUPER::get($_[0], $_[1]) ;
 455         $_[1] -= 2 ;
 456    }
 457
 458    sub A_new_method
 459    {
 460         my $self = shift ;
 461         my $key = shift ;
 462         my $value = $self->FETCH($key) ;
 463         return "[[$value]]" ;
 464    }
 465
 466    1 ;
 467 EOM
 468
 469     close FILE ;
 470
 471     BEGIN { push @INC, '.'; }
 472     eval 'use SubDB ; ';
 473     main::ok(53, $@ eq "") ;
 474     my %h ;
 475     my $X ;
 476     eval '
 477         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
 478         ' ;
 479
 480     main::ok(54, $@ eq "") ;
 481
 482     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 483     main::ok(55, $@ eq "") ;
 484     main::ok(56, $ret == 5) ;
 485
 486     my $value = 0;
 487     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 488     main::ok(57, $@ eq "") ;
 489     main::ok(58, $ret == 10) ;
 490
 491     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 492     main::ok(59, $@ eq "" ) ;
 493     main::ok(60, $ret == 1) ;
 494
 495     $ret = eval '$X->A_new_method("joe") ' ;
 496     main::ok(61, $@ eq "") ;
 497     main::ok(62, $ret eq "[[11]]") ;
 498
 499     undef $X;
 500     untie(%h);
 501     unlink "SubDB.pm", "dbhash.tmp" ;
 502
 503 }
 504
 505 {
 506    # DBM Filter tests
 507    use warnings ;
 508    use strict ;
 509    my (%h, $db) ;
 510    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 511    unlink $Dfile;
 512
 513    sub checkOutput
 514    {
 515        no warnings 'uninitialized';
 516        my($fk, $sk, $fv, $sv) = @_ ;
 517
 518        print "# Fetch Key   : expected '$fk' got '$fetch_key'\n"
 519            if $fetch_key ne $fk ;
 520        print "# Fetch Value : expected '$fv' got '$fetch_value'\n"
 521            if $fetch_value ne $fv ;
 522        print "# Store Key   : expected '$sk' got '$store_key'\n"
 523            if $store_key ne $sk ;
 524        print "# Store Value : expected '$sv' got '$store_value'\n"
 525            if $store_value ne $sv ;
 526        print "# \$_          : expected 'original' got '$_'\n"
 527            if $_ ne 'original' ;
 528
 529        return
 530            $fetch_key   eq $fk && $store_key   eq $sk &&
 531            $fetch_value eq $fv && $store_value eq $sv &&
 532            $_ eq 'original' ;
 533    }
 534
 535    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 536
 537    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 538    $db->filter_store_key   (sub { $store_key = $_ }) ;
 539    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 540    $db->filter_store_value (sub { $store_value = $_ }) ;
 541
 542    $_ = "original" ;
 543
 544    $h{"fred"} = "joe" ;
 545    #                   fk   sk     fv   sv
 546    ok(64, checkOutput( "", "fred", "", "joe")) ;
 547
 548    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 549    ok(65, $h{"fred"} eq "joe");
 550    #                   fk    sk     fv    sv
 551    ok(66, checkOutput( "", "fred", "joe", "")) ;
 552
 553    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 554    my ($k, $v) ;
 555    $k = 'fred';
 556    ok(67, ! $db->seq($k, $v, R_FIRST) ) ;
 557    ok(68, $k eq "fred") ;
 558    ok(69, $v eq "joe") ;
 559    #                    fk     sk  fv  sv
 560    ok(70, checkOutput( "fred", "fred", "joe", "")) ;
 561
 562    # replace the filters, but remember the previous set
 563    my ($old_fk) = $db->filter_fetch_key
 564                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 565    my ($old_sk) = $db->filter_store_key
 566                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 567    my ($old_fv) = $db->filter_fetch_value
 568                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 569    my ($old_sv) = $db->filter_store_value
 570                         (sub { s/o/x/g; $store_value = $_ }) ;
 571
 572    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 573    $h{"Fred"} = "Joe" ;
 574    #                   fk   sk     fv    sv
 575    ok(71, checkOutput( "", "fred", "", "Jxe")) ;
 576
 577    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 578    ok(72, $h{"Fred"} eq "[Jxe]");
 579    #                   fk   sk     fv    sv
 580    ok(73, checkOutput( "", "fred", "[Jxe]", "")) ;
 581
 582    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 583    $k = 'Fred'; $v ='';
 584    ok(74, ! $db->seq($k, $v, R_FIRST) ) ;
 585    ok(75, $k eq "Fred") ;
 586     #print "k [$k]\n" ;
 587    ok(76, $v eq "[Jxe]") ;
 588    #                   fk   sk     fv    sv
 589    ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
 590
 591    # put the original filters back
 592    $db->filter_fetch_key   ($old_fk);
 593    $db->filter_store_key   ($old_sk);
 594    $db->filter_fetch_value ($old_fv);
 595    $db->filter_store_value ($old_sv);
 596
 597    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 598    $h{"fred"} = "joe" ;
 599    ok(78, checkOutput( "", "fred", "", "joe")) ;
 600
 601    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 602    ok(79, $h{"fred"} eq "joe");
 603    ok(80, checkOutput( "", "fred", "joe", "")) ;
 604
 605    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 606    #ok(77, $db->FIRSTKEY() eq "fred") ;
 607    $k = 'fred';
 608    ok(81, ! $db->seq($k, $v, R_FIRST) ) ;
 609    ok(82, $k eq "fred") ;
 610    ok(83, $v eq "joe") ;
 611    #                   fk   sk     fv    sv
 612    ok(84, checkOutput( "fred", "fred", "joe", "")) ;
 613
 614    # delete the filters
 615    $db->filter_fetch_key   (undef);
 616    $db->filter_store_key   (undef);
 617    $db->filter_fetch_value (undef);
 618    $db->filter_store_value (undef);
 619
 620    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 621    $h{"fred"} = "joe" ;
 622    ok(85, checkOutput( "", "", "", "")) ;
 623
 624    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 625    ok(86, $h{"fred"} eq "joe");
 626    ok(87, checkOutput( "", "", "", "")) ;
 627
 628    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 629    $k = 'fred';
 630    ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
 631    ok(89, $k eq "fred") ;
 632    ok(90, $v eq "joe") ;
 633    ok(91, checkOutput( "", "", "", "")) ;
 634
 635    undef $db ;
 636    untie %h;
 637    unlink $Dfile;
 638 }
 639
 640 {
 641     # DBM Filter with a closure
 642
 643     use warnings ;
 644     use strict ;
 645     my (%h, $db) ;
 646
 647     unlink $Dfile;
 648     ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 649
 650     my %result = () ;
 651
 652     sub Closure
 653     {
 654         my ($name) = @_ ;
 655         my $count = 0 ;
 656         my @kept = () ;
 657
 658         return sub { ++$count ;
 659                      push @kept, $_ ;
 660                      $result{$name} = "$name - $count: [@kept]" ;
 661                    }
 662     }
 663
 664     $db->filter_store_key(Closure("store key")) ;
 665     $db->filter_store_value(Closure("store value")) ;
 666     $db->filter_fetch_key(Closure("fetch key")) ;
 667     $db->filter_fetch_value(Closure("fetch value")) ;
 668
 669     $_ = "original" ;
 670
 671     $h{"fred"} = "joe" ;
 672     ok(93, $result{"store key"} eq "store key - 1: [fred]");
 673     ok(94, $result{"store value"} eq "store value - 1: [joe]");
 674     ok(95, ! defined $result{"fetch key"} );
 675     ok(96, ! defined $result{"fetch value"} );
 676     ok(97, $_ eq "original") ;
 677
 678     ok(98, $db->FIRSTKEY() eq "fred") ;
 679     ok(99, $result{"store key"} eq "store key - 1: [fred]");
 680     ok(100, $result{"store value"} eq "store value - 1: [joe]");
 681     ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
 682     ok(102, ! defined $result{"fetch value"} );
 683     ok(103, $_ eq "original") ;
 684
 685     $h{"jim"}  = "john" ;
 686     ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
 687     ok(105, $result{"store value"} eq "store value - 2: [joe john]");
 688     ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
 689     ok(107, ! defined $result{"fetch value"} );
 690     ok(108, $_ eq "original") ;
 691
 692     ok(109, $h{"fred"} eq "joe");
 693     ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
 694     ok(111, $result{"store value"} eq "store value - 2: [joe john]");
 695     ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
 696     ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
 697     ok(114, $_ eq "original") ;
 698
 699     undef $db ;
 700     untie %h;
 701     unlink $Dfile;
 702 }
 703
 704 {
 705    # DBM Filter recursion detection
 706    use warnings ;
 707    use strict ;
 708    my (%h, $db) ;
 709    unlink $Dfile;
 710
 711    ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 712
 713    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 714
 715    eval '$h{1} = 1234' ;
 716    ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
 717
 718    undef $db ;
 719    untie %h;
 720    unlink $Dfile;
 721 }
 722
 723
 724 {
 725    # Examples from the POD
 726
 727   my $file = "xyzt" ;
 728   {
 729     my $redirect = new Redirect $file ;
 730
 731     use warnings FATAL => qw(all);
 732     use strict ;
 733     use DB_File ;
 734     our (%h, $k, $v);
 735
 736     unlink "fruit" ;
 737     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
 738         or die "Cannot open file 'fruit': $!\n";
 739
 740     # Add a few key/value pairs to the file
 741     $h{"apple"} = "red" ;
 742     $h{"orange"} = "orange" ;
 743     $h{"banana"} = "yellow" ;
 744     $h{"tomato"} = "red" ;
 745
 746     # Check for existence of a key
 747     print "Banana Exists\n\n" if $h{"banana"} ;
 748
 749     # Delete a key/value pair.
 750     delete $h{"apple"} ;
 751
 752     # print the contents of the file
 753     while (($k, $v) = each %h)
 754       { print "$k -> $v\n" }
 755
 756     untie %h ;
 757
 758     unlink "fruit" ;
 759   }
 760
 761   ok(117, docat_del($file) eq <<'EOM') ;
 762 Banana Exists
 763
 764 orange -> orange
 765 tomato -> red
 766 banana -> yellow
 767 EOM
 768
 769 }
 770
 771 {
 772     # Bug ID 20001013.009
 773     #
 774     # test that $hash{KEY} = undef doesn't produce the warning
 775     #     Use of uninitialized value in null operation
 776     use warnings ;
 777     use strict ;
 778     use DB_File ;
 779
 780     unlink $Dfile;
 781     my %h ;
 782     my $a = "";
 783     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 784
 785     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 786     $h{ABC} = undef;
 787     ok(118, $a eq "") ;
 788     untie %h ;
 789     unlink $Dfile;
 790 }
 791
 792 {
 793     # test that %hash = () doesn't produce the warning
 794     #     Argument "" isn't numeric in entersub
 795     use warnings ;
 796     use strict ;
 797     use DB_File ;
 798
 799     unlink $Dfile;
 800     my %h ;
 801     my $a = "";
 802     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 803
 804     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 805     %h = (); ;
 806     ok(119, $a eq "") ;
 807     untie %h ;
 808     unlink $Dfile;
 809 }
 810
 811 {
 812     # When iterating over a tied hash using "each", the key passed to FETCH
 813     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
 814     # key in FETCH via a filter_fetch_key method we need to check that the
 815     # modified key doesn't get passed to NEXTKEY.
 816     # Also Test "keys" & "values" while we are at it.
 817
 818     use warnings ;
 819     use strict ;
 820     use DB_File ;
 821
 822     unlink $Dfile;
 823     my $bad_key = 0 ;
 824     my %h = () ;
 825     my $db ;
 826     ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 827     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
 828     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
 829
 830     $h{'Alpha_ABC'} = 2 ;
 831     $h{'Alpha_DEF'} = 5 ;
 832
 833     ok(121, $h{'Alpha_ABC'} == 2);
 834     ok(122, $h{'Alpha_DEF'} == 5);
 835
 836     my ($k, $v) = ("","");
 837     while (($k, $v) = each %h) {}
 838     ok(123, $bad_key == 0);
 839
 840     $bad_key = 0 ;
 841     foreach $k (keys %h) {}
 842     ok(124, $bad_key == 0);
 843
 844     $bad_key = 0 ;
 845     foreach $v (values %h) {}
 846     ok(125, $bad_key == 0);
 847
 848     undef $db ;
 849     untie %h ;
 850     unlink $Dfile;
 851 }
 852
 853 {
 854     # now an error to pass 'hash' a non-code reference
 855     my $dbh = new DB_File::HASHINFO ;
 856
 857     eval { $dbh->{hash} = 2 };
 858     ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);
 859
 860 }
 861
 862
 863 #{
 864 #    # recursion detection in hash
 865 #    my %hash ;
 866 #    my $Dfile = "xxx.db";
 867 #    unlink $Dfile;
 868 #    my $dbh = new DB_File::HASHINFO ;
 869 #    $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
 870 #
 871 #
 872 #    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
 873 #
 874 #    eval {     $hash{1} = 2;
 875 #               $hash{4} = 5;
 876 #        };
 877 #
 878 #    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
 879 #    {
 880 #        local ($^W) = 0; #no warnings;
 881 #        untie %hash;
 882 #    }
 883 #    unlink $Dfile;
 884 #}
 885
 886 #ok(127,1);
 887 #ok(128,1);
 888
 889 {
 890     # Check that two hash's don't interact
 891     my %hash1 ;
 892     my %hash2 ;
 893     my $h1_count = 0;
 894     my $h2_count = 0;
 895     unlink $Dfile, $Dfile2;
 896     my $dbh1 = new DB_File::HASHINFO ;
 897     $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;
 898
 899     my $dbh2 = new DB_File::HASHINFO ;
 900     $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
 901
 902
 903
 904     my (%h);
 905     ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
 906     ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
 907
 908     $hash1{DEFG} = 5;
 909     $hash1{XYZ} = 2;
 910     $hash1{ABCDE} = 5;
 911
 912     $hash2{defg} = 5;
 913     $hash2{xyz} = 2;
 914     $hash2{abcde} = 5;
 915
 916     ok(129, $h1_count > 0);
 917     ok(130, $h1_count == $h2_count);
 918
 919     ok(131, safeUntie \%hash1);
 920     ok(132, safeUntie \%hash2);
 921     unlink $Dfile, $Dfile2;
 922 }
 923
 924 {
 925     # Passing undef for flags and/or mode when calling tie could cause
 926     #     Use of uninitialized value in subroutine entry
 927
 928
 929     my $warn_count = 0 ;
 930     #local $SIG{__WARN__} = sub { ++ $warn_count };
 931     my %hash1;
 932     unlink $Dfile;
 933
 934     tie %hash1, 'DB_File',$Dfile, undef;
 935     ok(133, $warn_count == 0);
 936     $warn_count = 0;
 937     unlink $Dfile;
 938     tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
 939     ok(134, $warn_count == 0);
 940     unlink $Dfile;
 941     tie %hash1, 'DB_File',$Dfile, undef, undef;
 942     ok(135, $warn_count == 0);
 943     $warn_count = 0;
 944
 945     untie %hash1;
 946     unlink $Dfile;
 947 }
 948
 949 {
 950    # Check that DBM Filter can cope with read-only $_
 951
 952    use warnings ;
 953    use strict ;
 954    my (%h, $db) ;
 955    my $Dfile = "xxy.db";
 956    unlink $Dfile;
 957
 958    ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 959
 960    $db->filter_fetch_key   (sub { }) ;
 961    $db->filter_store_key   (sub { }) ;
 962    $db->filter_fetch_value (sub { }) ;
 963    $db->filter_store_value (sub { }) ;
 964
 965    $_ = "original" ;
 966
 967    $h{"fred"} = "joe" ;
 968    ok(137, $h{"fred"} eq "joe");
 969
 970    eval { grep { $h{$_} } (1, 2, 3) };
 971    ok (138, ! $@);
 972
 973
 974    # delete the filters
 975    $db->filter_fetch_key   (undef);
 976    $db->filter_store_key   (undef);
 977    $db->filter_fetch_value (undef);
 978    $db->filter_store_value (undef);
 979
 980    $h{"fred"} = "joe" ;
 981
 982    ok(139, $h{"fred"} eq "joe");
 983
 984    ok(140, $db->FIRSTKEY() eq "fred") ;
 985
 986    eval { grep { $h{$_} } (1, 2, 3) };
 987    ok (141, ! $@);
 988
 989    undef $db ;
 990    untie %h;
 991    unlink $Dfile;
 992 }
 993
 994 {
 995    # Check low-level API works with filter
 996
 997    use warnings ;
 998    use strict ;
 999    my (%h, $db) ;
1000    my $Dfile = "xxy.db";
1001    unlink $Dfile;
1002
1003    ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
1004
1005
1006    $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
1007    $db->filter_store_key   (sub { $_ = pack("i", $_) } );
1008    $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
1009    $db->filter_store_value (sub { $_ = pack("i", $_) } );
1010
1011    $_ = 'fred';
1012
1013    my $key = 22 ;
1014    my $value = 34 ;
1015
1016    $db->put($key, $value) ;
1017    ok 143, $key == 22;
1018    ok 144, $value == 34 ;
1019    ok 145, $_ eq 'fred';
1020    #print "k [$key][$value]\n" ;
1021
1022    my $val ;
1023    $db->get($key, $val) ;
1024    ok 146, $key == 22;
1025    ok 147, $val == 34 ;
1026    ok 148, $_ eq 'fred';
1027
1028    $key = 51 ;
1029    $value = 454;
1030    $h{$key} = $value ;
1031    ok 149, $key == 51;
1032    ok 150, $value == 454 ;
1033    ok 151, $_ eq 'fred';
1034
1035    undef $db ;
1036    untie %h;
1037    unlink $Dfile;
1038 }
1039
1040
1041 {
1042     # Regression Test for bug 30237
1043     # Check that substr can be used in the key to db_put
1044     # and that db_put does not trigger the warning
1045     #
1046     #     Use of uninitialized value in subroutine entry
1047
1048
1049     use warnings ;
1050     use strict ;
1051     my (%h, $db) ;
1052     my $Dfile = "xxy.db";
1053     unlink $Dfile;
1054
1055     ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
1056
1057     my $warned = '';
1058     local $SIG{__WARN__} = sub {$warned = $_[0]} ;
1059
1060     # db-put with substr of key
1061     my %remember = () ;
1062     for my $ix ( 1 .. 2 )
1063     {
1064         my $key = $ix . "data" ;
1065         my $value = "value$ix" ;
1066         $remember{$key} = $value ;
1067         $db->put(substr($key,0), $value) ;
1068     }
1069
1070     ok 153, $warned eq ''
1071       or print "# Caught warning [$warned]\n" ;
1072
1073     # db-put with substr of value
1074     $warned = '';
1075     for my $ix ( 10 .. 12 )
1076     {
1077         my $key = $ix . "data" ;
1078         my $value = "value$ix" ;
1079         $remember{$key} = $value ;
1080         $db->put($key, substr($value,0)) ;
1081     }
1082
1083     ok 154, $warned eq ''
1084       or print "# Caught warning [$warned]\n" ;
1085
1086     # via the tied hash is not a problem, but check anyway
1087     # substr of key
1088     $warned = '';
1089     for my $ix ( 30 .. 32 )
1090     {
1091         my $key = $ix . "data" ;
1092         my $value = "value$ix" ;
1093         $remember{$key} = $value ;
1094         $h{substr($key,0)} = $value ;
1095     }
1096
1097     ok 155, $warned eq ''
1098       or print "# Caught warning [$warned]\n" ;
1099
1100     # via the tied hash is not a problem, but check anyway
1101     # substr of value
1102     $warned = '';
1103     for my $ix ( 40 .. 42 )
1104     {
1105         my $key = $ix . "data" ;
1106         my $value = "value$ix" ;
1107         $remember{$key} = $value ;
1108         $h{$key} = substr($value,0) ;
1109     }
1110
1111     ok 156, $warned eq ''
1112       or print "# Caught warning [$warned]\n" ;
1113
1114     my %bad = () ;
1115     $key = '';
1116     for ($status = $db->seq($key, $value, R_FIRST ) ;
1117          $status == 0 ;
1118          $status = $db->seq($key, $value, R_NEXT ) ) {
1119
1120         #print "# key [$key] value [$value]\n" ;
1121         if (defined $remember{$key} && defined $value &&
1122              $remember{$key} eq $value) {
1123             delete $remember{$key} ;
1124         }
1125         else {
1126             $bad{$key} = $value ;
1127         }
1128     }
1129
1130     ok 157, keys %bad == 0 ;
1131     ok 158, keys %remember == 0 ;
1132
1133     print "# missing -- $key $value\n" while ($key, $value) = each %remember;
1134     print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
1135
1136     # Make sure this fix does not break code to handle an undef key
1137     # Berkeley DB undef key is bron between versions 2.3.16 and
1138     my $value = 'fred';
1139     $warned = '';
1140     $db->put(undef, $value) ;
1141     ok 159, $warned eq ''
1142       or print "# Caught warning [$warned]\n" ;
1143     $warned = '';
1144
1145     my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
1146     print "# db_ver $DB_File::db_ver\n";
1147     $value = '' ;
1148     $db->get(undef, $value) ;
1149     ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
1150     ok 161, $warned eq ''
1151       or print "# Caught warning [$warned]\n" ;
1152     $warned = '';
1153
1154     undef $db ;
1155     untie %h;
1156     unlink $Dfile;
1157 }
1158
1159 exit ;