ext/DB_File/t/db-hash.t

   1 #!./perl
   2
   3 use warnings;
   4 use strict;
   5 use Config;
   6
   7 BEGIN {
   8     if($ENV{PERL_CORE}) {
   9         if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
  10             print "1..0 # Skip: DB_File was not built\n";
  11             exit 0;
  12         }
  13     }
  14 }
  15
  16 use DB_File;
  17 use Fcntl;
  18
  19 print "1..166\n";
  20
  21 unlink glob "__db.*";
  22
  23 sub ok
  24 {
  25     my $no = shift ;
  26     my $result = shift ;
  27
  28     print "not " unless $result ;
  29     print "ok $no\n" ;
  30
  31     return $result ;
  32 }
  33
  34 {
  35     package Redirect ;
  36     use Symbol ;
  37
  38     sub new
  39     {
  40         my $class = shift ;
  41         my $filename = shift ;
  42         my $fh = gensym ;
  43         open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  44         my $real_stdout = select($fh) ;
  45         return bless [$fh, $real_stdout ] ;
  46
  47     }
  48     sub DESTROY
  49     {
  50         my $self = shift ;
  51         close $self->[0] ;
  52         select($self->[1]) ;
  53     }
  54 }
  55
  56 sub docat_del
  57 {
  58     my $file = shift;
  59     local $/ = undef;
  60     open(CAT,$file) || die "Cannot open $file: $!";
  61     my $result = <CAT>;
  62     close(CAT);
  63     $result = normalise($result) ;
  64     unlink $file ;
  65     return $result;
  66 }
  67
  68 sub normalise
  69 {
  70     my $data = shift ;
  71     $data =~ s#\r\n#\n#g
  72         if $^O eq 'cygwin' ;
  73     return $data ;
  74 }
  75
  76 sub safeUntie
  77 {
  78     my $hashref = shift ;
  79     my $no_inner = 1;
  80     local $SIG{__WARN__} = sub {-- $no_inner } ;
  81     untie %$hashref;
  82     return $no_inner;
  83 }
  84
  85
  86 my $Dfile = "dbhash.tmp";
  87 my $Dfile2 = "dbhash2.tmp";
  88 my $null_keys_allowed = ($DB_File::db_ver < 2.004010
  89                                 || $DB_File::db_ver >= 3.1 );
  90
  91 unlink $Dfile;
  92
  93 umask(0);
  94
  95 # Check the interface to HASHINFO
  96
  97 my $dbh = new DB_File::HASHINFO ;
  98
  99 ok(1, ! defined $dbh->{bsize}) ;
 100 ok(2, ! defined $dbh->{ffactor}) ;
 101 ok(3, ! defined $dbh->{nelem}) ;
 102 ok(4, ! defined $dbh->{cachesize}) ;
 103 ok(5, ! defined $dbh->{hash}) ;
 104 ok(6, ! defined $dbh->{lorder}) ;
 105
 106 $dbh->{bsize} = 3000 ;
 107 ok(7, $dbh->{bsize} == 3000 );
 108
 109 $dbh->{ffactor} = 9000 ;
 110 ok(8, $dbh->{ffactor} == 9000 );
 111
 112 $dbh->{nelem} = 400 ;
 113 ok(9, $dbh->{nelem} == 400 );
 114
 115 $dbh->{cachesize} = 65 ;
 116 ok(10, $dbh->{cachesize} == 65 );
 117
 118 my $some_sub = sub {} ;
 119 $dbh->{hash} = $some_sub;
 120 ok(11, $dbh->{hash} eq $some_sub );
 121
 122 $dbh->{lorder} = 1234 ;
 123 ok(12, $dbh->{lorder} == 1234 );
 124
 125 # Check that an invalid entry is caught both for store & fetch
 126 eval '$dbh->{fred} = 1234' ;
 127 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
 128 eval 'my $q = $dbh->{fred}' ;
 129 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
 130
 131
 132 # Now check the interface to HASH
 133 my ($X, %h);
 134 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 135 die "Could not tie: $!" unless $X;
 136
 137 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 138    $blksize,$blocks) = stat($Dfile);
 139
 140 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 141
 142 ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
 143    $noMode{$^O} );
 144
 145 my ($key, $value, $i);
 146 while (($key,$value) = each(%h)) {
 147     $i++;
 148 }
 149 ok(17, !$i );
 150
 151 $h{'goner1'} = 'snork';
 152
 153 $h{'abc'} = 'ABC';
 154 ok(18, $h{'abc'} eq 'ABC' );
 155 ok(19, !defined $h{'jimmy'} );
 156 ok(20, !exists $h{'jimmy'} );
 157 ok(21, exists $h{'abc'} );
 158
 159 $h{'def'} = 'DEF';
 160 $h{'jkl','mno'} = "JKL\034MNO";
 161 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
 162 $h{'a'} = 'A';
 163
 164 #$h{'b'} = 'B';
 165 $X->STORE('b', 'B') ;
 166
 167 $h{'c'} = 'C';
 168
 169 #$h{'d'} = 'D';
 170 $X->put('d', 'D') ;
 171
 172 $h{'e'} = 'E';
 173 $h{'f'} = 'F';
 174 $h{'g'} = 'X';
 175 $h{'h'} = 'H';
 176 $h{'i'} = 'I';
 177
 178 $h{'goner2'} = 'snork';
 179 delete $h{'goner2'};
 180
 181
 182 # IMPORTANT - $X must be undefined before the untie otherwise the
 183 #             underlying DB close routine will not get called.
 184 undef $X ;
 185 untie(%h);
 186
 187
 188 # tie to the same file again, do not supply a type - should default to HASH
 189 ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
 190
 191 # Modify an entry from the previous tie
 192 $h{'g'} = 'G';
 193
 194 $h{'j'} = 'J';
 195 $h{'k'} = 'K';
 196 $h{'l'} = 'L';
 197 $h{'m'} = 'M';
 198 $h{'n'} = 'N';
 199 $h{'o'} = 'O';
 200 $h{'p'} = 'P';
 201 $h{'q'} = 'Q';
 202 $h{'r'} = 'R';
 203 $h{'s'} = 'S';
 204 $h{'t'} = 'T';
 205 $h{'u'} = 'U';
 206 $h{'v'} = 'V';
 207 $h{'w'} = 'W';
 208 $h{'x'} = 'X';
 209 $h{'y'} = 'Y';
 210 $h{'z'} = 'Z';
 211
 212 $h{'goner3'} = 'snork';
 213
 214 delete $h{'goner1'};
 215 $X->DELETE('goner3');
 216
 217 my @keys = keys(%h);
 218 my @values = values(%h);
 219
 220 ok(23, $#keys == 29 && $#values == 29) ;
 221
 222 $i = 0 ;
 223 while (($key,$value) = each(%h)) {
 224     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 225         $key =~ y/a-z/A-Z/;
 226         $i++ if $key eq $value;
 227     }
 228 }
 229
 230 ok(24, $i == 30) ;
 231
 232 @keys = ('blurfl', keys(%h), 'dyick');
 233 ok(25, $#keys == 31) ;
 234
 235 $h{'foo'} = '';
 236 ok(26, $h{'foo'} eq '' );
 237
 238 # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
 239 # This feature was reenabled in version 3.1 of Berkeley DB.
 240 my $result = 0 ;
 241 if ($null_keys_allowed) {
 242     $h{''} = 'bar';
 243     $result = ( $h{''} eq 'bar' );
 244 }
 245 else
 246   { $result = 1 }
 247 ok(27, $result) ;
 248
 249 # check cache overflow and numeric keys and contents
 250 my $ok = 1;
 251 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 252 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 253 ok(28, $ok );
 254
 255 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 256    $blksize,$blocks) = stat($Dfile);
 257 ok(29, $size > 0 );
 258
 259 @h{0..200} = 200..400;
 260 my @foo = @h{0..200};
 261 ok(30, join(':',200..400) eq join(':',@foo) );
 262
 263
 264 # Now check all the non-tie specific stuff
 265
 266 # Check NOOVERWRITE will make put fail when attempting to overwrite
 267 # an existing record.
 268
 269 my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 270 ok(31, $status == 1 );
 271
 272 # check that the value of the key 'x' has not been changed by the
 273 # previous test
 274 ok(32, $h{'x'} eq 'X' );
 275
 276 # standard put
 277 $status = $X->put('key', 'value') ;
 278 ok(33, $status == 0 );
 279
 280 #check that previous put can be retrieved
 281 $value = 0 ;
 282 $status = $X->get('key', $value) ;
 283 ok(34, $status == 0 );
 284 ok(35, $value eq 'value' );
 285
 286 # Attempting to delete an existing key should work
 287
 288 $status = $X->del('q') ;
 289 ok(36, $status == 0 );
 290
 291 # Make sure that the key deleted, cannot be retrieved
 292 {
 293     no warnings 'uninitialized' ;
 294     ok(37, $h{'q'} eq undef );
 295 }
 296
 297 # Attempting to delete a non-existant key should fail
 298
 299 $status = $X->del('joe') ;
 300 ok(38, $status == 1 );
 301
 302 # Check the get interface
 303
 304 # First a non-existing key
 305 $status = $X->get('aaaa', $value) ;
 306 ok(39, $status == 1 );
 307
 308 # Next an existing key
 309 $status = $X->get('a', $value) ;
 310 ok(40, $status == 0 );
 311 ok(41, $value eq 'A' );
 312
 313 # seq
 314 # ###
 315
 316 # ditto, but use put to replace the key/value pair.
 317
 318 # use seq to walk backwards through a file - check that this reversed is
 319
 320 # check seq FIRST/LAST
 321
 322 # sync
 323 # ####
 324
 325 $status = $X->sync ;
 326 ok(42, $status == 0 );
 327
 328
 329 # fd
 330 # ##
 331
 332 $status = $X->fd ;
 333 ok(43, 1 );
 334 #ok(43, $status != 0 );
 335
 336 undef $X ;
 337 untie %h ;
 338
 339 unlink $Dfile;
 340
 341 # clear
 342 # #####
 343
 344 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 345 foreach (1 .. 10)
 346   { $h{$_} = $_ * 100 }
 347
 348 # check that there are 10 elements in the hash
 349 $i = 0 ;
 350 while (($key,$value) = each(%h)) {
 351     $i++;
 352 }
 353 ok(45, $i == 10);
 354
 355 # now clear the hash
 356 %h = () ;
 357
 358 # check it is empty
 359 $i = 0 ;
 360 while (($key,$value) = each(%h)) {
 361     $i++;
 362 }
 363 ok(46, $i == 0);
 364
 365 untie %h ;
 366 unlink $Dfile ;
 367
 368
 369 # Now try an in memory file
 370 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 371
 372 # fd with an in memory file should return fail
 373 $status = $X->fd ;
 374 ok(48, $status == -1 );
 375
 376 undef $X ;
 377 untie %h ;
 378
 379 {
 380     # check ability to override the default hashing
 381     my %x ;
 382     my $filename = "xyz" ;
 383     my $hi = new DB_File::HASHINFO ;
 384     $::count = 0 ;
 385     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 386     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 387     $h{"abc"} = 123 ;
 388     ok(50, $h{"abc"} == 123) ;
 389     untie %x ;
 390     unlink $filename ;
 391     ok(51, $::count >0) ;
 392 }
 393
 394 {
 395     # check that attempting to tie an array to a DB_HASH will fail
 396
 397     my $filename = "xyz" ;
 398     my @x ;
 399     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
 400     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
 401     unlink $filename ;
 402 }
 403
 404 {
 405    # sub-class test
 406
 407    package Another ;
 408
 409    use warnings ;
 410    use strict ;
 411
 412    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 413    print FILE <<'EOM' ;
 414
 415    package SubDB ;
 416
 417    use warnings ;
 418    use strict ;
 419    our (@ISA, @EXPORT);
 420
 421    require Exporter ;
 422    use DB_File;
 423    @ISA=qw(DB_File);
 424    @EXPORT = @DB_File::EXPORT ;
 425
 426    sub STORE {
 427         my $self = shift ;
 428         my $key = shift ;
 429         my $value = shift ;
 430         $self->SUPER::STORE($key, $value * 2) ;
 431    }
 432
 433    sub FETCH {
 434         my $self = shift ;
 435         my $key = shift ;
 436         $self->SUPER::FETCH($key) - 1 ;
 437    }
 438
 439    sub put {
 440         my $self = shift ;
 441         my $key = shift ;
 442         my $value = shift ;
 443         $self->SUPER::put($key, $value * 3) ;
 444    }
 445
 446    sub get {
 447         my $self = shift ;
 448         $self->SUPER::get($_[0], $_[1]) ;
 449         $_[1] -= 2 ;
 450    }
 451
 452    sub A_new_method
 453    {
 454         my $self = shift ;
 455         my $key = shift ;
 456         my $value = $self->FETCH($key) ;
 457         return "[[$value]]" ;
 458    }
 459
 460    1 ;
 461 EOM
 462
 463     close FILE ;
 464
 465     BEGIN { push @INC, '.'; }
 466     eval 'use SubDB ; ';
 467     main::ok(53, $@ eq "") ;
 468     my %h ;
 469     my $X ;
 470     eval '
 471         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
 472         ' ;
 473
 474     main::ok(54, $@ eq "") ;
 475
 476     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 477     main::ok(55, $@ eq "") ;
 478     main::ok(56, $ret == 5) ;
 479
 480     my $value = 0;
 481     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 482     main::ok(57, $@ eq "") ;
 483     main::ok(58, $ret == 10) ;
 484
 485     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 486     main::ok(59, $@ eq "" ) ;
 487     main::ok(60, $ret == 1) ;
 488
 489     $ret = eval '$X->A_new_method("joe") ' ;
 490     main::ok(61, $@ eq "") ;
 491     main::ok(62, $ret eq "[[11]]") ;
 492
 493     undef $X;
 494     untie(%h);
 495     unlink "SubDB.pm", "dbhash.tmp" ;
 496
 497 }
 498
 499 {
 500    # DBM Filter tests
 501    use warnings ;
 502    use strict ;
 503    my (%h, $db) ;
 504    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 505    unlink $Dfile;
 506
 507    sub checkOutput
 508    {
 509        no warnings 'uninitialized';
 510        my($fk, $sk, $fv, $sv) = @_ ;
 511
 512        print "# Fetch Key   : expected '$fk' got '$fetch_key'\n"
 513            if $fetch_key ne $fk ;
 514        print "# Fetch Value : expected '$fv' got '$fetch_value'\n"
 515            if $fetch_value ne $fv ;
 516        print "# Store Key   : expected '$sk' got '$store_key'\n"
 517            if $store_key ne $sk ;
 518        print "# Store Value : expected '$sv' got '$store_value'\n"
 519            if $store_value ne $sv ;
 520        print "# \$_          : expected 'original' got '$_'\n"
 521            if $_ ne 'original' ;
 522
 523        return
 524            $fetch_key   eq $fk && $store_key   eq $sk &&
 525            $fetch_value eq $fv && $store_value eq $sv &&
 526            $_ eq 'original' ;
 527    }
 528
 529    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 530
 531    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 532    $db->filter_store_key   (sub { $store_key = $_ }) ;
 533    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 534    $db->filter_store_value (sub { $store_value = $_ }) ;
 535
 536    $_ = "original" ;
 537
 538    $h{"fred"} = "joe" ;
 539    #                   fk   sk     fv   sv
 540    ok(64, checkOutput( "", "fred", "", "joe")) ;
 541
 542    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 543    ok(65, $h{"fred"} eq "joe");
 544    #                   fk    sk     fv    sv
 545    ok(66, checkOutput( "", "fred", "joe", "")) ;
 546
 547    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 548    my ($k, $v) ;
 549    $k = 'fred';
 550    ok(67, ! $db->seq($k, $v, R_FIRST) ) ;
 551    ok(68, $k eq "fred") ;
 552    ok(69, $v eq "joe") ;
 553    #                    fk     sk  fv  sv
 554    ok(70, checkOutput( "fred", "fred", "joe", "")) ;
 555
 556    # replace the filters, but remember the previous set
 557    my ($old_fk) = $db->filter_fetch_key
 558                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 559    my ($old_sk) = $db->filter_store_key
 560                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 561    my ($old_fv) = $db->filter_fetch_value
 562                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 563    my ($old_sv) = $db->filter_store_value
 564                         (sub { s/o/x/g; $store_value = $_ }) ;
 565
 566    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 567    $h{"Fred"} = "Joe" ;
 568    #                   fk   sk     fv    sv
 569    ok(71, checkOutput( "", "fred", "", "Jxe")) ;
 570
 571    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 572    ok(72, $h{"Fred"} eq "[Jxe]");
 573    #                   fk   sk     fv    sv
 574    ok(73, checkOutput( "", "fred", "[Jxe]", "")) ;
 575
 576    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 577    $k = 'Fred'; $v ='';
 578    ok(74, ! $db->seq($k, $v, R_FIRST) ) ;
 579    ok(75, $k eq "FRED") or
 580     print "# k [$k]\n" ;
 581    ok(76, $v eq "[Jxe]") ;
 582    #                   fk   sk     fv    sv
 583    ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
 584
 585    # put the original filters back
 586    $db->filter_fetch_key   ($old_fk);
 587    $db->filter_store_key   ($old_sk);
 588    $db->filter_fetch_value ($old_fv);
 589    $db->filter_store_value ($old_sv);
 590
 591    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 592    $h{"fred"} = "joe" ;
 593    ok(78, checkOutput( "", "fred", "", "joe")) ;
 594
 595    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 596    ok(79, $h{"fred"} eq "joe");
 597    ok(80, checkOutput( "", "fred", "joe", "")) ;
 598
 599    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 600    #ok(77, $db->FIRSTKEY() eq "fred") ;
 601    $k = 'fred';
 602    ok(81, ! $db->seq($k, $v, R_FIRST) ) ;
 603    ok(82, $k eq "fred") ;
 604    ok(83, $v eq "joe") ;
 605    #                   fk   sk     fv    sv
 606    ok(84, checkOutput( "fred", "fred", "joe", "")) ;
 607
 608    # delete the filters
 609    $db->filter_fetch_key   (undef);
 610    $db->filter_store_key   (undef);
 611    $db->filter_fetch_value (undef);
 612    $db->filter_store_value (undef);
 613
 614    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 615    $h{"fred"} = "joe" ;
 616    ok(85, checkOutput( "", "", "", "")) ;
 617
 618    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 619    ok(86, $h{"fred"} eq "joe");
 620    ok(87, checkOutput( "", "", "", "")) ;
 621
 622    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 623    $k = 'fred';
 624    ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
 625    ok(89, $k eq "fred") ;
 626    ok(90, $v eq "joe") ;
 627    ok(91, checkOutput( "", "", "", "")) ;
 628
 629    undef $db ;
 630    untie %h;
 631    unlink $Dfile;
 632 }
 633
 634 {
 635     # DBM Filter with a closure
 636
 637     use warnings ;
 638     use strict ;
 639     my (%h, $db) ;
 640
 641     unlink $Dfile;
 642     ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 643
 644     my %result = () ;
 645
 646     sub Closure
 647     {
 648         my ($name) = @_ ;
 649         my $count = 0 ;
 650         my @kept = () ;
 651
 652         return sub { ++$count ;
 653                      push @kept, $_ ;
 654                      $result{$name} = "$name - $count: [@kept]" ;
 655                    }
 656     }
 657
 658     $db->filter_store_key(Closure("store key")) ;
 659     $db->filter_store_value(Closure("store value")) ;
 660     $db->filter_fetch_key(Closure("fetch key")) ;
 661     $db->filter_fetch_value(Closure("fetch value")) ;
 662
 663     $_ = "original" ;
 664
 665     $h{"fred"} = "joe" ;
 666     ok(93, $result{"store key"} eq "store key - 1: [fred]");
 667     ok(94, $result{"store value"} eq "store value - 1: [joe]");
 668     ok(95, ! defined $result{"fetch key"} );
 669     ok(96, ! defined $result{"fetch value"} );
 670     ok(97, $_ eq "original") ;
 671
 672     ok(98, $db->FIRSTKEY() eq "fred") ;
 673     ok(99, $result{"store key"} eq "store key - 1: [fred]");
 674     ok(100, $result{"store value"} eq "store value - 1: [joe]");
 675     ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
 676     ok(102, ! defined $result{"fetch value"} );
 677     ok(103, $_ eq "original") ;
 678
 679     $h{"jim"}  = "john" ;
 680     ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
 681     ok(105, $result{"store value"} eq "store value - 2: [joe john]");
 682     ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
 683     ok(107, ! defined $result{"fetch value"} );
 684     ok(108, $_ eq "original") ;
 685
 686     ok(109, $h{"fred"} eq "joe");
 687     ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
 688     ok(111, $result{"store value"} eq "store value - 2: [joe john]");
 689     ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
 690     ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
 691     ok(114, $_ eq "original") ;
 692
 693     undef $db ;
 694     untie %h;
 695     unlink $Dfile;
 696 }
 697
 698 {
 699    # DBM Filter recursion detection
 700    use warnings ;
 701    use strict ;
 702    my (%h, $db) ;
 703    unlink $Dfile;
 704
 705    ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 706
 707    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 708
 709    eval '$h{1} = 1234' ;
 710    ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
 711
 712    undef $db ;
 713    untie %h;
 714    unlink $Dfile;
 715 }
 716
 717
 718 {
 719    # Examples from the POD
 720
 721   my $file = "xyzt" ;
 722   {
 723     my $redirect = new Redirect $file ;
 724
 725     use warnings FATAL => qw(all);
 726     use strict ;
 727     use DB_File ;
 728     our (%h, $k, $v);
 729
 730     unlink "fruit" ;
 731     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
 732         or die "Cannot open file 'fruit': $!\n";
 733
 734     # Add a few key/value pairs to the file
 735     $h{"apple"} = "red" ;
 736     $h{"orange"} = "orange" ;
 737     $h{"banana"} = "yellow" ;
 738     $h{"tomato"} = "red" ;
 739
 740     # Check for existence of a key
 741     print "Banana Exists\n\n" if $h{"banana"} ;
 742
 743     # Delete a key/value pair.
 744     delete $h{"apple"} ;
 745
 746     # print the contents of the file
 747     while (($k, $v) = each %h)
 748       { print "$k -> $v\n" }
 749
 750     untie %h ;
 751
 752     unlink "fruit" ;
 753   }
 754
 755   ok(117, docat_del($file) eq <<'EOM') ;
 756 Banana Exists
 757
 758 orange -> orange
 759 tomato -> red
 760 banana -> yellow
 761 EOM
 762
 763 }
 764
 765 {
 766     # Bug ID 20001013.009
 767     #
 768     # test that $hash{KEY} = undef doesn't produce the warning
 769     #     Use of uninitialized value in null operation
 770     use warnings ;
 771     use strict ;
 772     use DB_File ;
 773
 774     unlink $Dfile;
 775     my %h ;
 776     my $a = "";
 777     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 778
 779     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 780     $h{ABC} = undef;
 781     ok(118, $a eq "") ;
 782     untie %h ;
 783     unlink $Dfile;
 784 }
 785
 786 {
 787     # test that %hash = () doesn't produce the warning
 788     #     Argument "" isn't numeric in entersub
 789     use warnings ;
 790     use strict ;
 791     use DB_File ;
 792
 793     unlink $Dfile;
 794     my %h ;
 795     my $a = "";
 796     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 797
 798     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
 799     %h = (); ;
 800     ok(119, $a eq "") ;
 801     untie %h ;
 802     unlink $Dfile;
 803 }
 804
 805 {
 806     # When iterating over a tied hash using "each", the key passed to FETCH
 807     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
 808     # key in FETCH via a filter_fetch_key method we need to check that the
 809     # modified key doesn't get passed to NEXTKEY.
 810     # Also Test "keys" & "values" while we are at it.
 811
 812     use warnings ;
 813     use strict ;
 814     use DB_File ;
 815
 816     unlink $Dfile;
 817     my $bad_key = 0 ;
 818     my %h = () ;
 819     my $db ;
 820     ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 821     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
 822     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
 823
 824     $h{'Alpha_ABC'} = 2 ;
 825     $h{'Alpha_DEF'} = 5 ;
 826
 827     ok(121, $h{'Alpha_ABC'} == 2);
 828     ok(122, $h{'Alpha_DEF'} == 5);
 829
 830     my ($k, $v) = ("","");
 831     while (($k, $v) = each %h) {}
 832     ok(123, $bad_key == 0);
 833
 834     $bad_key = 0 ;
 835     foreach $k (keys %h) {}
 836     ok(124, $bad_key == 0);
 837
 838     $bad_key = 0 ;
 839     foreach $v (values %h) {}
 840     ok(125, $bad_key == 0);
 841
 842     undef $db ;
 843     untie %h ;
 844     unlink $Dfile;
 845 }
 846
 847 {
 848     # now an error to pass 'hash' a non-code reference
 849     my $dbh = new DB_File::HASHINFO ;
 850
 851     eval { $dbh->{hash} = 2 };
 852     ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);
 853
 854 }
 855
 856
 857 #{
 858 #    # recursion detection in hash
 859 #    my %hash ;
 860 #    my $Dfile = "xxx.db";
 861 #    unlink $Dfile;
 862 #    my $dbh = new DB_File::HASHINFO ;
 863 #    $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
 864 #
 865 #
 866 #    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
 867 #
 868 #    eval {     $hash{1} = 2;
 869 #               $hash{4} = 5;
 870 #        };
 871 #
 872 #    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
 873 #    {
 874 #        no warnings;
 875 #        untie %hash;
 876 #    }
 877 #    unlink $Dfile;
 878 #}
 879
 880 #ok(127, 1);
 881 #ok(128, 1);
 882
 883 {
 884     # Check that two hash's don't interact
 885     my %hash1 ;
 886     my %hash2 ;
 887     my $h1_count = 0;
 888     my $h2_count = 0;
 889     unlink $Dfile, $Dfile2;
 890     my $dbh1 = new DB_File::HASHINFO ;
 891     $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;
 892
 893     my $dbh2 = new DB_File::HASHINFO ;
 894     $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
 895
 896
 897
 898     my (%h);
 899     ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
 900     ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
 901
 902     $hash1{DEFG} = 5;
 903     $hash1{XYZ} = 2;
 904     $hash1{ABCDE} = 5;
 905
 906     $hash2{defg} = 5;
 907     $hash2{xyz} = 2;
 908     $hash2{abcde} = 5;
 909
 910     ok(129, $h1_count > 0);
 911     ok(130, $h1_count == $h2_count);
 912
 913     ok(131, safeUntie \%hash1);
 914     ok(132, safeUntie \%hash2);
 915     unlink $Dfile, $Dfile2;
 916 }
 917
 918 {
 919     # Passing undef for flags and/or mode when calling tie could cause
 920     #     Use of uninitialized value in subroutine entry
 921
 922
 923     my $warn_count = 0 ;
 924     #local $SIG{__WARN__} = sub { ++ $warn_count };
 925     my %hash1;
 926     unlink $Dfile;
 927
 928     tie %hash1, 'DB_File',$Dfile, undef;
 929     ok(133, $warn_count == 0);
 930     $warn_count = 0;
 931     untie %hash1;
 932     unlink $Dfile;
 933     tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
 934     ok(134, $warn_count == 0);
 935     untie %hash1;
 936     unlink $Dfile;
 937     tie %hash1, 'DB_File',$Dfile, undef, undef;
 938     ok(135, $warn_count == 0);
 939     $warn_count = 0;
 940
 941     untie %hash1;
 942     unlink $Dfile;
 943 }
 944
 945 {
 946    # Check that DBM Filter can cope with read-only $_
 947
 948    use warnings ;
 949    use strict ;
 950    my (%h, $db) ;
 951    my $Dfile = "xxy.db";
 952    unlink $Dfile;
 953
 954    ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 955
 956    $db->filter_fetch_key   (sub { }) ;
 957    $db->filter_store_key   (sub { }) ;
 958    $db->filter_fetch_value (sub { }) ;
 959    $db->filter_store_value (sub { }) ;
 960
 961    $_ = "original" ;
 962
 963    $h{"fred"} = "joe" ;
 964    ok(137, $h{"fred"} eq "joe");
 965
 966    eval { my @r= grep { $h{$_} } (1, 2, 3) };
 967    ok (138, ! $@);
 968
 969
 970    # delete the filters
 971    $db->filter_fetch_key   (undef);
 972    $db->filter_store_key   (undef);
 973    $db->filter_fetch_value (undef);
 974    $db->filter_store_value (undef);
 975
 976    $h{"fred"} = "joe" ;
 977
 978    ok(139, $h{"fred"} eq "joe");
 979
 980    ok(140, $db->FIRSTKEY() eq "fred") ;
 981
 982    eval { my @r= grep { $h{$_} } (1, 2, 3) };
 983    ok (141, ! $@);
 984
 985    undef $db ;
 986    untie %h;
 987    unlink $Dfile;
 988 }
 989
 990 {
 991    # Check low-level API works with filter
 992
 993    use warnings ;
 994    use strict ;
 995    my (%h, $db) ;
 996    my $Dfile = "xxy.db";
 997    unlink $Dfile;
 998
 999    ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
1000
1001
1002    $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
1003    $db->filter_store_key   (sub { $_ = pack("i", $_) } );
1004    $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
1005    $db->filter_store_value (sub { $_ = pack("i", $_) } );
1006
1007    $_ = 'fred';
1008
1009    my $key = 22 ;
1010    my $value = 34 ;
1011
1012    $db->put($key, $value) ;
1013    ok 143, $key == 22;
1014    ok 144, $value == 34 ;
1015    ok 145, $_ eq 'fred';
1016    #print "k [$key][$value]\n" ;
1017
1018    my $val ;
1019    $db->get($key, $val) ;
1020    ok 146, $key == 22;
1021    ok 147, $val == 34 ;
1022    ok 148, $_ eq 'fred';
1023
1024    $key = 51 ;
1025    $value = 454;
1026    $h{$key} = $value ;
1027    ok 149, $key == 51;
1028    ok 150, $value == 454 ;
1029    ok 151, $_ eq 'fred';
1030
1031    undef $db ;
1032    untie %h;
1033    unlink $Dfile;
1034 }
1035
1036
1037 {
1038     # Regression Test for bug 30237
1039     # Check that substr can be used in the key to db_put
1040     # and that db_put does not trigger the warning
1041     #
1042     #     Use of uninitialized value in subroutine entry
1043
1044
1045     use warnings ;
1046     use strict ;
1047     my (%h, $db) ;
1048     my $Dfile = "xxy.db";
1049     unlink $Dfile;
1050
1051     ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
1052
1053     my $warned = '';
1054     local $SIG{__WARN__} = sub {$warned = $_[0]} ;
1055
1056     # db-put with substr of key
1057     my %remember = () ;
1058     for my $ix ( 1 .. 2 )
1059     {
1060         my $key = $ix . "data" ;
1061         my $value = "value$ix" ;
1062         $remember{$key} = $value ;
1063         $db->put(substr($key,0), $value) ;
1064     }
1065
1066     ok 153, $warned eq ''
1067       or print "# Caught warning [$warned]\n" ;
1068
1069     # db-put with substr of value
1070     $warned = '';
1071     for my $ix ( 10 .. 12 )
1072     {
1073         my $key = $ix . "data" ;
1074         my $value = "value$ix" ;
1075         $remember{$key} = $value ;
1076         $db->put($key, substr($value,0)) ;
1077     }
1078
1079     ok 154, $warned eq ''
1080       or print "# Caught warning [$warned]\n" ;
1081
1082     # via the tied hash is not a problem, but check anyway
1083     # substr of key
1084     $warned = '';
1085     for my $ix ( 30 .. 32 )
1086     {
1087         my $key = $ix . "data" ;
1088         my $value = "value$ix" ;
1089         $remember{$key} = $value ;
1090         $h{substr($key,0)} = $value ;
1091     }
1092
1093     ok 155, $warned eq ''
1094       or print "# Caught warning [$warned]\n" ;
1095
1096     # via the tied hash is not a problem, but check anyway
1097     # substr of value
1098     $warned = '';
1099     for my $ix ( 40 .. 42 )
1100     {
1101         my $key = $ix . "data" ;
1102         my $value = "value$ix" ;
1103         $remember{$key} = $value ;
1104         $h{$key} = substr($value,0) ;
1105     }
1106
1107     ok 156, $warned eq ''
1108       or print "# Caught warning [$warned]\n" ;
1109
1110     my %bad = () ;
1111     $key = '';
1112     for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
1113          $status == 0 ;
1114          $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {
1115
1116         #print "# key [$key] value [$value]\n" ;
1117         if (defined $remember{$key} && defined $value &&
1118              $remember{$key} eq $value) {
1119             delete $remember{$key} ;
1120         }
1121         else {
1122             $bad{$key} = $value ;
1123         }
1124     }
1125
1126     ok 157, keys %bad == 0 ;
1127     ok 158, keys %remember == 0 ;
1128
1129     print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
1130     print "# bad     -- $key=>$value\n" while ($key, $value) = each %bad;
1131
1132     # Make sure this fix does not break code to handle an undef key
1133     # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
1134     my $value = 'fred';
1135     $warned = '';
1136     $db->put(undef, $value) ;
1137     ok 159, $warned eq ''
1138       or print "# Caught warning [$warned]\n" ;
1139     $warned = '';
1140
1141     my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
1142     print "# db_ver $DB_File::db_ver\n";
1143     $value = '' ;
1144     $db->get(undef, $value) ;
1145     ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
1146     ok 161, $warned eq ''
1147       or print "# Caught warning [$warned]\n" ;
1148     $warned = '';
1149
1150     undef $db ;
1151     untie %h;
1152     unlink $Dfile;
1153 }
1154
1155 {
1156    # Check filter + substr
1157
1158    use warnings ;
1159    use strict ;
1160    my (%h, $db) ;
1161    my $Dfile = "xxy.db";
1162    unlink $Dfile;
1163
1164    ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
1165
1166
1167    {
1168        $db->filter_fetch_key   (sub { lc $_ } );
1169        $db->filter_store_key   (sub { uc $_ } );
1170        $db->filter_fetch_value (sub { lc $_ } );
1171        $db->filter_store_value (sub { uc $_ } );
1172    }
1173
1174    $_ = 'fred';
1175
1176     # db-put with substr of key
1177     my %remember = () ;
1178     my $status = 0 ;
1179     for my $ix ( 1 .. 2 )
1180     {
1181         my $key = $ix . "data" ;
1182         my $value = "value$ix" ;
1183         $remember{$key} = $value ;
1184         $status += $db->put(substr($key,0), substr($value,0)) ;
1185     }
1186
1187     ok 163, $status == 0 or print "# Status $status\n" ;
1188
1189     if (1)
1190     {
1191        $db->filter_fetch_key   (undef);
1192        $db->filter_store_key   (undef);
1193        $db->filter_fetch_value (undef);
1194        $db->filter_store_value (undef);
1195     }
1196
1197     my %bad = () ;
1198     my $key = '';
1199     my $value = '';
1200     for ($status = $db->seq($key, $value, R_FIRST ) ;
1201          $status == 0 ;
1202          $status = $db->seq($key, $value, R_NEXT ) ) {
1203
1204         #print "# key [$key] value [$value]\n" ;
1205         if (defined $remember{$key} && defined $value &&
1206              $remember{$key} eq $value) {
1207             delete $remember{$key} ;
1208         }
1209         else {
1210             $bad{$key} = $value ;
1211         }
1212     }
1213
1214     ok 164, $_ eq 'fred';
1215     ok 165, keys %bad == 0 ;
1216     ok 166, keys %remember == 0 ;
1217
1218     print "# missing -- $key $value\n" while ($key, $value) = each %remember;
1219     print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
1220    undef $db ;
1221    untie %h;
1222    unlink $Dfile;
1223 }
1224
1225 exit ;