ext/DB_File/t/db-btree.t

   1 #!./perl -w
   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     if ($^O eq 'darwin'
  22         && $Config{db_version_major} == 1
  23         && $Config{db_version_minor} == 0
  24         && $Config{db_version_patch} == 0) {
  25         warn <<EOM;
  26 #
  27 # This test is known to crash in Mac OS X versions 10.2 (or earlier)
  28 # because of the buggy Berkeley DB version included with the OS.
  29 #
  30 EOM
  31     }
  32 }
  33
  34 use DB_File;
  35 use Fcntl;
  36
  37 print "1..177\n";
  38
  39 unlink glob "__db.*";
  40
  41 sub ok
  42 {
  43     my $no = shift ;
  44     my $result = shift ;
  45
  46     print "not " unless $result ;
  47     print "ok $no\n" ;
  48 }
  49
  50 sub lexical
  51 {
  52     my(@a) = unpack ("C*", $a) ;
  53     my(@b) = unpack ("C*", $b) ;
  54
  55     my $len = (@a > @b ? @b : @a) ;
  56     my $i = 0 ;
  57
  58     foreach $i ( 0 .. $len -1) {
  59         return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
  60     }
  61
  62     return @a - @b ;
  63 }
  64
  65 {
  66     package Redirect ;
  67     use Symbol ;
  68
  69     sub new
  70     {
  71         my $class = shift ;
  72         my $filename = shift ;
  73         my $fh = gensym ;
  74         open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  75         my $real_stdout = select($fh) ;
  76         return bless [$fh, $real_stdout ] ;
  77
  78     }
  79     sub DESTROY
  80     {
  81         my $self = shift ;
  82         close $self->[0] ;
  83         select($self->[1]) ;
  84     }
  85 }
  86
  87 sub docat
  88 {
  89     my $file = shift;
  90     local $/ = undef ;
  91     open(CAT,$file) || die "Cannot open $file: $!";
  92     my $result = <CAT>;
  93     close(CAT);
  94     $result = normalise($result) ;
  95     return $result ;
  96 }
  97
  98 sub docat_del
  99 {
 100     my $file = shift;
 101     my $result = docat($file);
 102     unlink $file ;
 103     return $result ;
 104 }
 105
 106 sub normalise
 107 {
 108     my $data = shift ;
 109     $data =~ s#\r\n#\n#g
 110         if $^O eq 'cygwin' ;
 111
 112     return $data ;
 113 }
 114
 115 sub safeUntie
 116 {
 117     my $hashref = shift ;
 118     my $no_inner = 1;
 119     local $SIG{__WARN__} = sub {-- $no_inner } ;
 120     untie %$hashref;
 121     return $no_inner;
 122 }
 123
 124
 125
 126 my $db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
 127 my $null_keys_allowed = ($DB_File::db_ver < 2.004010
 128                                 || $DB_File::db_ver >= 3.1 );
 129
 130 my $Dfile = "dbbtree.tmp";
 131 unlink $Dfile;
 132
 133 umask(0);
 134
 135 # Check the interface to BTREEINFO
 136
 137 my $dbh = new DB_File::BTREEINFO ;
 138 ok(1, ! defined $dbh->{flags}) ;
 139 ok(2, ! defined $dbh->{cachesize}) ;
 140 ok(3, ! defined $dbh->{psize}) ;
 141 ok(4, ! defined $dbh->{lorder}) ;
 142 ok(5, ! defined $dbh->{minkeypage}) ;
 143 ok(6, ! defined $dbh->{maxkeypage}) ;
 144 ok(7, ! defined $dbh->{compare}) ;
 145 ok(8, ! defined $dbh->{prefix}) ;
 146
 147 $dbh->{flags} = 3000 ;
 148 ok(9, $dbh->{flags} == 3000) ;
 149
 150 $dbh->{cachesize} = 9000 ;
 151 ok(10, $dbh->{cachesize} == 9000);
 152
 153 $dbh->{psize} = 400 ;
 154 ok(11, $dbh->{psize} == 400) ;
 155
 156 $dbh->{lorder} = 65 ;
 157 ok(12, $dbh->{lorder} == 65) ;
 158
 159 $dbh->{minkeypage} = 123 ;
 160 ok(13, $dbh->{minkeypage} == 123) ;
 161
 162 $dbh->{maxkeypage} = 1234 ;
 163 ok(14, $dbh->{maxkeypage} == 1234 );
 164
 165 # Check that an invalid entry is caught both for store & fetch
 166 eval '$dbh->{fred} = 1234' ;
 167 ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
 168 eval 'my $q = $dbh->{fred}' ;
 169 ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
 170
 171 # Now check the interface to BTREE
 172
 173 my ($X, %h) ;
 174 ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
 175 die "Could not tie: $!" unless $X;
 176
 177 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 178    $blksize,$blocks) = stat($Dfile);
 179
 180 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 181
 182 ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
 183    || $noMode{$^O} );
 184
 185 my ($key, $value, $i);
 186 while (($key,$value) = each(%h)) {
 187     $i++;
 188 }
 189 ok(19, !$i ) ;
 190
 191 $h{'goner1'} = 'snork';
 192
 193 $h{'abc'} = 'ABC';
 194 ok(20, $h{'abc'} eq 'ABC' );
 195 ok(21, ! defined $h{'jimmy'} ) ;
 196 ok(22, ! exists $h{'jimmy'} ) ;
 197 ok(23,  defined $h{'abc'} ) ;
 198
 199 $h{'def'} = 'DEF';
 200 $h{'jkl','mno'} = "JKL\034MNO";
 201 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
 202 $h{'a'} = 'A';
 203
 204 #$h{'b'} = 'B';
 205 $X->STORE('b', 'B') ;
 206
 207 $h{'c'} = 'C';
 208
 209 #$h{'d'} = 'D';
 210 $X->put('d', 'D') ;
 211
 212 $h{'e'} = 'E';
 213 $h{'f'} = 'F';
 214 $h{'g'} = 'X';
 215 $h{'h'} = 'H';
 216 $h{'i'} = 'I';
 217
 218 $h{'goner2'} = 'snork';
 219 delete $h{'goner2'};
 220
 221
 222 # IMPORTANT - $X must be undefined before the untie otherwise the
 223 #             underlying DB close routine will not get called.
 224 undef $X ;
 225 untie(%h);
 226
 227 # tie to the same file again
 228 ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
 229
 230 # Modify an entry from the previous tie
 231 $h{'g'} = 'G';
 232
 233 $h{'j'} = 'J';
 234 $h{'k'} = 'K';
 235 $h{'l'} = 'L';
 236 $h{'m'} = 'M';
 237 $h{'n'} = 'N';
 238 $h{'o'} = 'O';
 239 $h{'p'} = 'P';
 240 $h{'q'} = 'Q';
 241 $h{'r'} = 'R';
 242 $h{'s'} = 'S';
 243 $h{'t'} = 'T';
 244 $h{'u'} = 'U';
 245 $h{'v'} = 'V';
 246 $h{'w'} = 'W';
 247 $h{'x'} = 'X';
 248 $h{'y'} = 'Y';
 249 $h{'z'} = 'Z';
 250
 251 $h{'goner3'} = 'snork';
 252
 253 delete $h{'goner1'};
 254 $X->DELETE('goner3');
 255
 256 my @keys = keys(%h);
 257 my @values = values(%h);
 258
 259 ok(25, $#keys == 29 && $#values == 29) ;
 260
 261 $i = 0 ;
 262 while (($key,$value) = each(%h)) {
 263     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 264         $key =~ y/a-z/A-Z/;
 265         $i++ if $key eq $value;
 266     }
 267 }
 268
 269 ok(26, $i == 30) ;
 270
 271 @keys = ('blurfl', keys(%h), 'dyick');
 272 ok(27, $#keys == 31) ;
 273
 274 #Check that the keys can be retrieved in order
 275 my @b = keys %h ;
 276 my @c = sort lexical @b ;
 277 ok(28, ArrayCompare(\@b, \@c)) ;
 278
 279 $h{'foo'} = '';
 280 ok(29, $h{'foo'} eq '' ) ;
 281
 282 # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
 283 # This feature was reenabled in version 3.1 of Berkeley DB.
 284 my $result = 0 ;
 285 if ($null_keys_allowed) {
 286     $h{''} = 'bar';
 287     $result = ( $h{''} eq 'bar' );
 288 }
 289 else
 290   { $result = 1 }
 291 ok(30, $result) ;
 292
 293 # check cache overflow and numeric keys and contents
 294 my $ok = 1;
 295 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 296 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 297 ok(31, $ok);
 298
 299 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 300    $blksize,$blocks) = stat($Dfile);
 301 ok(32, $size > 0 );
 302
 303 @h{0..200} = 200..400;
 304 my @foo = @h{0..200};
 305 ok(33, join(':',200..400) eq join(':',@foo) );
 306
 307 # Now check all the non-tie specific stuff
 308
 309
 310 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
 311 # an existing record.
 312
 313 my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 314 ok(34, $status == 1 );
 315
 316 # check that the value of the key 'x' has not been changed by the
 317 # previous test
 318 ok(35, $h{'x'} eq 'X' );
 319
 320 # standard put
 321 $status = $X->put('key', 'value') ;
 322 ok(36, $status == 0 );
 323
 324 #check that previous put can be retrieved
 325 $value = 0 ;
 326 $status = $X->get('key', $value) ;
 327 ok(37, $status == 0 );
 328 ok(38, $value eq 'value' );
 329
 330 # Attempting to delete an existing key should work
 331
 332 $status = $X->del('q') ;
 333 ok(39, $status == 0 );
 334 if ($null_keys_allowed) {
 335     $status = $X->del('') ;
 336 } else {
 337     $status = 0 ;
 338 }
 339 ok(40, $status == 0 );
 340
 341 # Make sure that the key deleted, cannot be retrieved
 342 ok(41, ! defined $h{'q'}) ;
 343 ok(42, ! defined $h{''}) ;
 344
 345 undef $X ;
 346 untie %h ;
 347
 348 ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
 349
 350 # Attempting to delete a non-existant key should fail
 351
 352 $status = $X->del('joe') ;
 353 ok(44, $status == 1 );
 354
 355 # Check the get interface
 356
 357 # First a non-existing key
 358 $status = $X->get('aaaa', $value) ;
 359 ok(45, $status == 1 );
 360
 361 # Next an existing key
 362 $status = $X->get('a', $value) ;
 363 ok(46, $status == 0 );
 364 ok(47, $value eq 'A' );
 365
 366 # seq
 367 # ###
 368
 369 # use seq to find an approximate match
 370 $key = 'ke' ;
 371 $value = '' ;
 372 $status = $X->seq($key, $value, R_CURSOR) ;
 373 ok(48, $status == 0 );
 374 ok(49, $key eq 'key' );
 375 ok(50, $value eq 'value' );
 376
 377 # seq when the key does not match
 378 $key = 'zzz' ;
 379 $value = '' ;
 380 $status = $X->seq($key, $value, R_CURSOR) ;
 381 ok(51, $status == 1 );
 382
 383
 384 # use seq to set the cursor, then delete the record @ the cursor.
 385
 386 $key = 'x' ;
 387 $value = '' ;
 388 $status = $X->seq($key, $value, R_CURSOR) ;
 389 ok(52, $status == 0 );
 390 ok(53, $key eq 'x' );
 391 ok(54, $value eq 'X' );
 392 $status = $X->del(0, R_CURSOR) ;
 393 ok(55, $status == 0 );
 394 $status = $X->get('x', $value) ;
 395 ok(56, $status == 1 );
 396
 397 # ditto, but use put to replace the key/value pair.
 398 $key = 'y' ;
 399 $value = '' ;
 400 $status = $X->seq($key, $value, R_CURSOR) ;
 401 ok(57, $status == 0 );
 402 ok(58, $key eq 'y' );
 403 ok(59, $value eq 'Y' );
 404
 405 $key = "replace key" ;
 406 $value = "replace value" ;
 407 $status = $X->put($key, $value, R_CURSOR) ;
 408 ok(60, $status == 0 );
 409 ok(61, $key eq 'replace key' );
 410 ok(62, $value eq 'replace value' );
 411 $status = $X->get('y', $value) ;
 412 ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1)
 413             # only worked because of a bug in 1.85/6
 414
 415 # use seq to walk forwards through a file
 416
 417 $status = $X->seq($key, $value, R_FIRST) ;
 418 ok(64, $status == 0 );
 419 my $previous = $key ;
 420
 421 $ok = 1 ;
 422 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
 423 {
 424     ($ok = 0), last if ($previous cmp $key) == 1 ;
 425 }
 426
 427 ok(65, $status == 1 );
 428 ok(66, $ok == 1 );
 429
 430 # use seq to walk backwards through a file
 431 $status = $X->seq($key, $value, R_LAST) ;
 432 ok(67, $status == 0 );
 433 $previous = $key ;
 434
 435 $ok = 1 ;
 436 while (($status = $X->seq($key, $value, R_PREV)) == 0)
 437 {
 438     ($ok = 0), last if ($previous cmp $key) == -1 ;
 439     #print "key = [$key] value = [$value]\n" ;
 440 }
 441
 442 ok(68, $status == 1 );
 443 ok(69, $ok == 1 );
 444
 445
 446 # check seq FIRST/LAST
 447
 448 # sync
 449 # ####
 450
 451 $status = $X->sync ;
 452 ok(70, $status == 0 );
 453
 454
 455 # fd
 456 # ##
 457
 458 $status = $X->fd ;
 459 ok(71, $status != 0 );
 460
 461
 462 undef $X ;
 463 untie %h ;
 464
 465 unlink $Dfile;
 466
 467 # Now try an in memory file
 468 my $Y;
 469 ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
 470
 471 # fd with an in memory file should return failure
 472 $status = $Y->fd ;
 473 ok(73, $status == -1 );
 474
 475
 476 undef $Y ;
 477 untie %h ;
 478
 479 # Duplicate keys
 480 my $bt = new DB_File::BTREEINFO ;
 481 $bt->{flags} = R_DUP ;
 482 my ($YY, %hh);
 483 ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
 484
 485 $hh{'Wall'} = 'Larry' ;
 486 $hh{'Wall'} = 'Stone' ; # Note the duplicate key
 487 $hh{'Wall'} = 'Brick' ; # Note the duplicate key
 488 $hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
 489 $hh{'Smith'} = 'John' ;
 490 $hh{'mouse'} = 'mickey' ;
 491
 492 # first work in scalar context
 493 ok(75, scalar $YY->get_dup('Unknown') == 0 );
 494 ok(76, scalar $YY->get_dup('Smith') == 1 );
 495 ok(77, scalar $YY->get_dup('Wall') == 4 );
 496
 497 # now in list context
 498 my @unknown = $YY->get_dup('Unknown') ;
 499 ok(78, "@unknown" eq "" );
 500
 501 my @smith = $YY->get_dup('Smith') ;
 502 ok(79, "@smith" eq "John" );
 503
 504 {
 505 my @wall = $YY->get_dup('Wall') ;
 506 my %wall ;
 507 @wall{@wall} = @wall ;
 508 ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
 509 }
 510
 511 # hash
 512 my %unknown = $YY->get_dup('Unknown', 1) ;
 513 ok(81, keys %unknown == 0 );
 514
 515 my %smith = $YY->get_dup('Smith', 1) ;
 516 ok(82, keys %smith == 1 && $smith{'John'}) ;
 517
 518 my %wall = $YY->get_dup('Wall', 1) ;
 519 ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
 520                 && $wall{'Brick'} == 2);
 521
 522 undef $YY ;
 523 untie %hh ;
 524 unlink $Dfile;
 525
 526
 527 # test multiple callbacks
 528 my $Dfile1 = "btree1" ;
 529 my $Dfile2 = "btree2" ;
 530 my $Dfile3 = "btree3" ;
 531
 532 my $dbh1 = new DB_File::BTREEINFO ;
 533 $dbh1->{compare} = sub {
 534         no warnings 'numeric' ;
 535         $_[0] <=> $_[1] } ;
 536
 537 my $dbh2 = new DB_File::BTREEINFO ;
 538 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
 539
 540 my $dbh3 = new DB_File::BTREEINFO ;
 541 $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
 542
 543
 544 my (%g, %k);
 545 tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!;
 546 tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!;
 547 tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!;
 548
 549 my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
 550 my (@srt_1, @srt_2, @srt_3);
 551 {
 552   no warnings 'numeric' ;
 553   @srt_1 = sort { $a <=> $b } @Keys ;
 554 }
 555 @srt_2 = sort { $a cmp $b } @Keys ;
 556 @srt_3 = sort { length $a <=> length $b } @Keys ;
 557
 558 foreach (@Keys) {
 559     $h{$_} = 1 ;
 560     $g{$_} = 1 ;
 561     $k{$_} = 1 ;
 562 }
 563
 564 sub ArrayCompare
 565 {
 566     my($a, $b) = @_ ;
 567
 568     return 0 if @$a != @$b ;
 569
 570     foreach (1 .. length @$a)
 571     {
 572         return 0 unless $$a[$_] eq $$b[$_] ;
 573     }
 574
 575     1 ;
 576 }
 577
 578 ok(84, ArrayCompare (\@srt_1, [keys %h]) );
 579 ok(85, ArrayCompare (\@srt_2, [keys %g]) );
 580 ok(86, ArrayCompare (\@srt_3, [keys %k]) );
 581
 582 untie %h ;
 583 untie %g ;
 584 untie %k ;
 585 unlink $Dfile1, $Dfile2, $Dfile3 ;
 586
 587 # clear
 588 # #####
 589
 590 ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
 591 foreach (1 .. 10)
 592   { $h{$_} = $_ * 100 }
 593
 594 # check that there are 10 elements in the hash
 595 $i = 0 ;
 596 while (($key,$value) = each(%h)) {
 597     $i++;
 598 }
 599 ok(88, $i == 10);
 600
 601 # now clear the hash
 602 %h = () ;
 603
 604 # check it is empty
 605 $i = 0 ;
 606 while (($key,$value) = each(%h)) {
 607     $i++;
 608 }
 609 ok(89, $i == 0);
 610
 611 untie %h ;
 612 unlink $Dfile1 ;
 613
 614 {
 615     # check that attempting to tie an array to a DB_BTREE will fail
 616
 617     my $filename = "xyz" ;
 618     my @x ;
 619     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
 620     ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
 621     unlink $filename ;
 622 }
 623
 624 {
 625    # sub-class test
 626
 627    package Another ;
 628
 629    use warnings ;
 630    use strict ;
 631
 632    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 633    print FILE <<'EOM' ;
 634
 635    package SubDB ;
 636
 637    use warnings ;
 638    use strict ;
 639    our (@ISA, @EXPORT);
 640
 641    require Exporter ;
 642    use DB_File;
 643    @ISA=qw(DB_File);
 644    @EXPORT = @DB_File::EXPORT ;
 645
 646    sub STORE {
 647         my $self = shift ;
 648         my $key = shift ;
 649         my $value = shift ;
 650         $self->SUPER::STORE($key, $value * 2) ;
 651    }
 652
 653    sub FETCH {
 654         my $self = shift ;
 655         my $key = shift ;
 656         $self->SUPER::FETCH($key) - 1 ;
 657    }
 658
 659    sub put {
 660         my $self = shift ;
 661         my $key = shift ;
 662         my $value = shift ;
 663         $self->SUPER::put($key, $value * 3) ;
 664    }
 665
 666    sub get {
 667         my $self = shift ;
 668         $self->SUPER::get($_[0], $_[1]) ;
 669         $_[1] -= 2 ;
 670    }
 671
 672    sub A_new_method
 673    {
 674         my $self = shift ;
 675         my $key = shift ;
 676         my $value = $self->FETCH($key) ;
 677         return "[[$value]]" ;
 678    }
 679
 680    1 ;
 681 EOM
 682
 683     close FILE ;
 684
 685     BEGIN { push @INC, '.'; }
 686     eval 'use SubDB ; ';
 687     main::ok(91, $@ eq "") ;
 688     my %h ;
 689     my $X ;
 690     eval '
 691         $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
 692         ' ;
 693
 694     main::ok(92, $@ eq "") ;
 695
 696     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 697     main::ok(93, $@ eq "") ;
 698     main::ok(94, $ret == 5) ;
 699
 700     my $value = 0;
 701     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 702     main::ok(95, $@ eq "") ;
 703     main::ok(96, $ret == 10) ;
 704
 705     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 706     main::ok(97, $@ eq "" ) ;
 707     main::ok(98, $ret == 1) ;
 708
 709     $ret = eval '$X->A_new_method("joe") ' ;
 710     main::ok(99, $@ eq "") ;
 711     main::ok(100, $ret eq "[[11]]") ;
 712
 713     undef $X;
 714     untie(%h);
 715     unlink "SubDB.pm", "dbbtree.tmp" ;
 716
 717 }
 718
 719 {
 720    # DBM Filter tests
 721    use warnings ;
 722    use strict ;
 723    my (%h, $db) ;
 724    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 725    unlink $Dfile;
 726
 727    sub checkOutput
 728    {
 729        my($fk, $sk, $fv, $sv) = @_ ;
 730        return
 731            $fetch_key eq $fk && $store_key eq $sk &&
 732            $fetch_value eq $fv && $store_value eq $sv &&
 733            $_ eq 'original' ;
 734    }
 735
 736    ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
 737
 738    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 739    $db->filter_store_key   (sub { $store_key = $_ }) ;
 740    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 741    $db->filter_store_value (sub { $store_value = $_ }) ;
 742
 743    $_ = "original" ;
 744
 745    $h{"fred"} = "joe" ;
 746    #                   fk   sk     fv   sv
 747    ok(102, checkOutput( "", "fred", "", "joe")) ;
 748
 749    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 750    ok(103, $h{"fred"} eq "joe");
 751    #                   fk    sk     fv    sv
 752    ok(104, checkOutput( "", "fred", "joe", "")) ;
 753
 754    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 755    ok(105, $db->FIRSTKEY() eq "fred") ;
 756    #                    fk     sk  fv  sv
 757    ok(106, checkOutput( "fred", "", "", "")) ;
 758
 759    # replace the filters, but remember the previous set
 760    my ($old_fk) = $db->filter_fetch_key
 761                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 762    my ($old_sk) = $db->filter_store_key
 763                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 764    my ($old_fv) = $db->filter_fetch_value
 765                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 766    my ($old_sv) = $db->filter_store_value
 767                         (sub { s/o/x/g; $store_value = $_ }) ;
 768
 769    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 770    $h{"Fred"} = "Joe" ;
 771    #                   fk   sk     fv    sv
 772    ok(107, checkOutput( "", "fred", "", "Jxe")) ;
 773
 774    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 775    ok(108, $h{"Fred"} eq "[Jxe]");
 776    #                   fk   sk     fv    sv
 777    ok(109, checkOutput( "", "fred", "[Jxe]", "")) ;
 778
 779    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 780    ok(110, $db->FIRSTKEY() eq "FRED") ;
 781    #                   fk   sk     fv    sv
 782    ok(111, checkOutput( "FRED", "", "", "")) ;
 783
 784    # put the original filters back
 785    $db->filter_fetch_key   ($old_fk);
 786    $db->filter_store_key   ($old_sk);
 787    $db->filter_fetch_value ($old_fv);
 788    $db->filter_store_value ($old_sv);
 789
 790    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 791    $h{"fred"} = "joe" ;
 792    ok(112, checkOutput( "", "fred", "", "joe")) ;
 793
 794    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 795    ok(113, $h{"fred"} eq "joe");
 796    ok(114, checkOutput( "", "fred", "joe", "")) ;
 797
 798    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 799    ok(115, $db->FIRSTKEY() eq "fred") ;
 800    ok(116, checkOutput( "fred", "", "", "")) ;
 801
 802    # delete the filters
 803    $db->filter_fetch_key   (undef);
 804    $db->filter_store_key   (undef);
 805    $db->filter_fetch_value (undef);
 806    $db->filter_store_value (undef);
 807
 808    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 809    $h{"fred"} = "joe" ;
 810    ok(117, checkOutput( "", "", "", "")) ;
 811
 812    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 813    ok(118, $h{"fred"} eq "joe");
 814    ok(119, checkOutput( "", "", "", "")) ;
 815
 816    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 817    ok(120, $db->FIRSTKEY() eq "fred") ;
 818    ok(121, checkOutput( "", "", "", "")) ;
 819
 820    undef $db ;
 821    untie %h;
 822    unlink $Dfile;
 823 }
 824
 825 {
 826     # DBM Filter with a closure
 827
 828     use warnings ;
 829     use strict ;
 830     my (%h, $db) ;
 831
 832     unlink $Dfile;
 833     ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
 834
 835     my %result = () ;
 836
 837     sub Closure
 838     {
 839         my ($name) = @_ ;
 840         my $count = 0 ;
 841         my @kept = () ;
 842
 843         return sub { ++$count ;
 844                      push @kept, $_ ;
 845                      $result{$name} = "$name - $count: [@kept]" ;
 846                    }
 847     }
 848
 849     $db->filter_store_key(Closure("store key")) ;
 850     $db->filter_store_value(Closure("store value")) ;
 851     $db->filter_fetch_key(Closure("fetch key")) ;
 852     $db->filter_fetch_value(Closure("fetch value")) ;
 853
 854     $_ = "original" ;
 855
 856     $h{"fred"} = "joe" ;
 857     ok(123, $result{"store key"} eq "store key - 1: [fred]");
 858     ok(124, $result{"store value"} eq "store value - 1: [joe]");
 859     ok(125, ! defined $result{"fetch key"} );
 860     ok(126, ! defined $result{"fetch value"} );
 861     ok(127, $_ eq "original") ;
 862
 863     ok(128, $db->FIRSTKEY() eq "fred") ;
 864     ok(129, $result{"store key"} eq "store key - 1: [fred]");
 865     ok(130, $result{"store value"} eq "store value - 1: [joe]");
 866     ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]");
 867     ok(132, ! defined $result{"fetch value"} );
 868     ok(133, $_ eq "original") ;
 869
 870     $h{"jim"}  = "john" ;
 871     ok(134, $result{"store key"} eq "store key - 2: [fred jim]");
 872     ok(135, $result{"store value"} eq "store value - 2: [joe john]");
 873     ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]");
 874     ok(137, ! defined $result{"fetch value"} );
 875     ok(138, $_ eq "original") ;
 876
 877     ok(139, $h{"fred"} eq "joe");
 878     ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]");
 879     ok(141, $result{"store value"} eq "store value - 2: [joe john]");
 880     ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]");
 881     ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]");
 882     ok(144, $_ eq "original") ;
 883
 884     undef $db ;
 885     untie %h;
 886     unlink $Dfile;
 887 }
 888
 889 {
 890    # DBM Filter recursion detection
 891    use warnings ;
 892    use strict ;
 893    my (%h, $db) ;
 894    unlink $Dfile;
 895
 896    ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
 897
 898    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 899
 900    eval '$h{1} = 1234' ;
 901    ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
 902
 903    undef $db ;
 904    untie %h;
 905    unlink $Dfile;
 906 }
 907
 908
 909 {
 910    # Examples from the POD
 911
 912
 913   my $file = "xyzt" ;
 914   {
 915     my $redirect = new Redirect $file ;
 916
 917     # BTREE example 1
 918     ###
 919
 920     use warnings FATAL => qw(all) ;
 921     use strict ;
 922     use DB_File ;
 923
 924     my %h ;
 925
 926     sub Compare
 927     {
 928         my ($key1, $key2) = @_ ;
 929         "\L$key1" cmp "\L$key2" ;
 930     }
 931
 932     # specify the Perl sub that will do the comparison
 933     $DB_BTREE->{'compare'} = \&Compare ;
 934
 935     unlink "tree" ;
 936     tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
 937         or die "Cannot open file 'tree': $!\n" ;
 938
 939     # Add a key/value pair to the file
 940     $h{'Wall'} = 'Larry' ;
 941     $h{'Smith'} = 'John' ;
 942     $h{'mouse'} = 'mickey' ;
 943     $h{'duck'}  = 'donald' ;
 944
 945     # Delete
 946     delete $h{"duck"} ;
 947
 948     # Cycle through the keys printing them in order.
 949     # Note it is not necessary to sort the keys as
 950     # the btree will have kept them in order automatically.
 951     foreach (keys %h)
 952       { print "$_\n" }
 953
 954     untie %h ;
 955
 956     unlink "tree" ;
 957   }
 958
 959   delete $DB_BTREE->{'compare'} ;
 960
 961   ok(147, docat_del($file) eq <<'EOM') ;
 962 mouse
 963 Smith
 964 Wall
 965 EOM
 966
 967   {
 968     my $redirect = new Redirect $file ;
 969
 970     # BTREE example 2
 971     ###
 972
 973     use warnings FATAL => qw(all) ;
 974     use strict ;
 975     use DB_File ;
 976
 977     my ($filename, %h);
 978
 979     $filename = "tree" ;
 980     unlink $filename ;
 981
 982     # Enable duplicate records
 983     $DB_BTREE->{'flags'} = R_DUP ;
 984
 985     tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
 986         or die "Cannot open $filename: $!\n";
 987
 988     # Add some key/value pairs to the file
 989     $h{'Wall'} = 'Larry' ;
 990     $h{'Wall'} = 'Brick' ; # Note the duplicate key
 991     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
 992     $h{'Smith'} = 'John' ;
 993     $h{'mouse'} = 'mickey' ;
 994
 995     # iterate through the associative array
 996     # and print each key/value pair.
 997     foreach (keys %h)
 998       { print "$_       -> $h{$_}\n" }
 999
1000     untie %h ;
1001
1002     unlink $filename ;
1003   }
1004
1005   ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
1006 Smith   -> John
1007 Wall    -> Brick
1008 Wall    -> Brick
1009 Wall    -> Brick
1010 mouse   -> mickey
1011 EOM
1012 Smith   -> John
1013 Wall    -> Larry
1014 Wall    -> Larry
1015 Wall    -> Larry
1016 mouse   -> mickey
1017 EOM
1018
1019   {
1020     my $redirect = new Redirect $file ;
1021
1022     # BTREE example 3
1023     ###
1024
1025     use warnings FATAL => qw(all) ;
1026     use strict ;
1027     use DB_File ;
1028
1029     my ($filename, $x, %h, $status, $key, $value);
1030
1031     $filename = "tree" ;
1032     unlink $filename ;
1033
1034     # Enable duplicate records
1035     $DB_BTREE->{'flags'} = R_DUP ;
1036
1037     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
1038         or die "Cannot open $filename: $!\n";
1039
1040     # Add some key/value pairs to the file
1041     $h{'Wall'} = 'Larry' ;
1042     $h{'Wall'} = 'Brick' ; # Note the duplicate key
1043     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
1044     $h{'Smith'} = 'John' ;
1045     $h{'mouse'} = 'mickey' ;
1046
1047     # iterate through the btree using seq
1048     # and print each key/value pair.
1049     $key = $value = 0 ;
1050     for ($status = $x->seq($key, $value, R_FIRST) ;
1051          $status == 0 ;
1052          $status = $x->seq($key, $value, R_NEXT) )
1053       {  print "$key    -> $value\n" }
1054
1055
1056     undef $x ;
1057     untie %h ;
1058   }
1059
1060   ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
1061 Smith   -> John
1062 Wall    -> Brick
1063 Wall    -> Brick
1064 Wall    -> Larry
1065 mouse   -> mickey
1066 EOM
1067 Smith   -> John
1068 Wall    -> Larry
1069 Wall    -> Brick
1070 Wall    -> Brick
1071 mouse   -> mickey
1072 EOM
1073
1074
1075   {
1076     my $redirect = new Redirect $file ;
1077
1078     # BTREE example 4
1079     ###
1080
1081     use warnings FATAL => qw(all) ;
1082     use strict ;
1083     use DB_File ;
1084
1085     my ($filename, $x, %h);
1086
1087     $filename = "tree" ;
1088
1089     # Enable duplicate records
1090     $DB_BTREE->{'flags'} = R_DUP ;
1091
1092     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
1093         or die "Cannot open $filename: $!\n";
1094
1095     my $cnt  = $x->get_dup("Wall") ;
1096     print "Wall occurred $cnt times\n" ;
1097
1098     my %hash = $x->get_dup("Wall", 1) ;
1099     print "Larry is there\n" if $hash{'Larry'} ;
1100     print "There are $hash{'Brick'} Brick Walls\n" ;
1101
1102     my @list = sort $x->get_dup("Wall") ;
1103     print "Wall =>      [@list]\n" ;
1104
1105     @list = $x->get_dup("Smith") ;
1106     print "Smith =>     [@list]\n" ;
1107
1108     @list = $x->get_dup("Dog") ;
1109     print "Dog =>       [@list]\n" ;
1110
1111     undef $x ;
1112     untie %h ;
1113   }
1114
1115   ok(150, docat_del($file) eq <<'EOM') ;
1116 Wall occurred 3 times
1117 Larry is there
1118 There are 2 Brick Walls
1119 Wall => [Brick Brick Larry]
1120 Smith =>        [John]
1121 Dog =>  []
1122 EOM
1123
1124   {
1125     my $redirect = new Redirect $file ;
1126
1127     # BTREE example 5
1128     ###
1129
1130     use warnings FATAL => qw(all) ;
1131     use strict ;
1132     use DB_File ;
1133
1134     my ($filename, $x, %h, $found);
1135
1136     $filename = "tree" ;
1137
1138     # Enable duplicate records
1139     $DB_BTREE->{'flags'} = R_DUP ;
1140
1141     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
1142         or die "Cannot open $filename: $!\n";
1143
1144     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
1145     print "Larry Wall is $found there\n" ;
1146
1147     $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
1148     print "Harry Wall is $found there\n" ;
1149
1150     undef $x ;
1151     untie %h ;
1152   }
1153
1154   ok(151, docat_del($file) eq <<'EOM') ;
1155 Larry Wall is  there
1156 Harry Wall is not there
1157 EOM
1158
1159   {
1160     my $redirect = new Redirect $file ;
1161
1162     # BTREE example 6
1163     ###
1164
1165     use warnings FATAL => qw(all) ;
1166     use strict ;
1167     use DB_File ;
1168
1169     my ($filename, $x, %h, $found);
1170
1171     $filename = "tree" ;
1172
1173     # Enable duplicate records
1174     $DB_BTREE->{'flags'} = R_DUP ;
1175
1176     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
1177         or die "Cannot open $filename: $!\n";
1178
1179     $x->del_dup("Wall", "Larry") ;
1180
1181     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
1182     print "Larry Wall is $found there\n" ;
1183
1184     undef $x ;
1185     untie %h ;
1186
1187     unlink $filename ;
1188   }
1189
1190   ok(152, docat_del($file) eq <<'EOM') ;
1191 Larry Wall is not there
1192 EOM
1193
1194   {
1195     my $redirect = new Redirect $file ;
1196
1197     # BTREE example 7
1198     ###
1199
1200     use warnings FATAL => qw(all) ;
1201     use strict ;
1202     use DB_File ;
1203     use Fcntl ;
1204
1205     my ($filename, $x, %h, $st, $key, $value);
1206
1207     sub match
1208     {
1209         my $key = shift ;
1210         my $value = 0;
1211         my $orig_key = $key ;
1212         $x->seq($key, $value, R_CURSOR) ;
1213         print "$orig_key\t-> $key\t-> $value\n" ;
1214     }
1215
1216     $filename = "tree" ;
1217     unlink $filename ;
1218
1219     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
1220         or die "Cannot open $filename: $!\n";
1221
1222     # Add some key/value pairs to the file
1223     $h{'mouse'} = 'mickey' ;
1224     $h{'Wall'} = 'Larry' ;
1225     $h{'Walls'} = 'Brick' ;
1226     $h{'Smith'} = 'John' ;
1227
1228
1229     $key = $value = 0 ;
1230     print "IN ORDER\n" ;
1231     for ($st = $x->seq($key, $value, R_FIRST) ;
1232          $st == 0 ;
1233          $st = $x->seq($key, $value, R_NEXT) )
1234
1235       {  print "$key    -> $value\n" }
1236
1237     print "\nPARTIAL MATCH\n" ;
1238
1239     match "Wa" ;
1240     match "A" ;
1241     match "a" ;
1242
1243     undef $x ;
1244     untie %h ;
1245
1246     unlink $filename ;
1247
1248   }
1249
1250   ok(153, docat_del($file) eq <<'EOM') ;
1251 IN ORDER
1252 Smith   -> John
1253 Wall    -> Larry
1254 Walls   -> Brick
1255 mouse   -> mickey
1256
1257 PARTIAL MATCH
1258 Wa      -> Wall -> Larry
1259 A       -> Smith        -> John
1260 a       -> mouse        -> mickey
1261 EOM
1262
1263 }
1264
1265 #{
1266 #   # R_SETCURSOR
1267 #   use strict ;
1268 #   my (%h, $db) ;
1269 #   unlink $Dfile;
1270 #
1271 #   ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
1272 #
1273 #   $h{abc} = 33 ;
1274 #   my $k = "newest" ;
1275 #   my $v = 44 ;
1276 #   my $status = $db->put($k, $v, R_SETCURSOR) ;
1277 #   print "status = [$status]\n" ;
1278 #   ok(157, $status == 0) ;
1279 #   $status = $db->del($k, R_CURSOR) ;
1280 #   print "status = [$status]\n" ;
1281 #   ok(158, $status == 0) ;
1282 #   $k = "newest" ;
1283 #   ok(159, $db->get($k, $v, R_CURSOR)) ;
1284 #
1285 #   ok(160, keys %h == 1) ;
1286 #
1287 #   undef $db ;
1288 #   untie %h;
1289 #   unlink $Dfile;
1290 #}
1291
1292 {
1293     # Bug ID 20001013.009
1294     #
1295     # test that $hash{KEY} = undef doesn't produce the warning
1296     #     Use of uninitialized value in null operation
1297     use warnings ;
1298     use strict ;
1299     use DB_File ;
1300
1301     unlink $Dfile;
1302     my %h ;
1303     my $a = "";
1304     local $SIG{__WARN__} = sub {$a = $_[0]} ;
1305
1306     tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
1307         or die "Can't open file: $!\n" ;
1308     $h{ABC} = undef;
1309     ok(154, $a eq "") ;
1310     untie %h ;
1311     unlink $Dfile;
1312 }
1313
1314 {
1315     # test that %hash = () doesn't produce the warning
1316     #     Argument "" isn't numeric in entersub
1317     use warnings ;
1318     use strict ;
1319     use DB_File ;
1320
1321     unlink $Dfile;
1322     my %h ;
1323     my $a = "";
1324     local $SIG{__WARN__} = sub {$a = $_[0]} ;
1325
1326     tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
1327         or die "Can't open file: $!\n" ;
1328     %h = (); ;
1329     ok(155, $a eq "") ;
1330     untie %h ;
1331     unlink $Dfile;
1332 }
1333
1334 {
1335     # When iterating over a tied hash using "each", the key passed to FETCH
1336     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
1337     # key in FETCH via a filter_fetch_key method we need to check that the
1338     # modified key doesn't get passed to NEXTKEY.
1339     # Also Test "keys" & "values" while we are at it.
1340
1341     use warnings ;
1342     use strict ;
1343     use DB_File ;
1344
1345     unlink $Dfile;
1346     my $bad_key = 0 ;
1347     my %h = () ;
1348     my $db ;
1349     ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
1350     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
1351     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
1352
1353     $h{'Alpha_ABC'} = 2 ;
1354     $h{'Alpha_DEF'} = 5 ;
1355
1356     ok(157, $h{'Alpha_ABC'} == 2);
1357     ok(158, $h{'Alpha_DEF'} == 5);
1358
1359     my ($k, $v) = ("","");
1360     while (($k, $v) = each %h) {}
1361     ok(159, $bad_key == 0);
1362
1363     $bad_key = 0 ;
1364     foreach $k (keys %h) {}
1365     ok(160, $bad_key == 0);
1366
1367     $bad_key = 0 ;
1368     foreach $v (values %h) {}
1369     ok(161, $bad_key == 0);
1370
1371     undef $db ;
1372     untie %h ;
1373     unlink $Dfile;
1374 }
1375
1376 {
1377     # now an error to pass 'compare' a non-code reference
1378     my $dbh = new DB_File::BTREEINFO ;
1379
1380     eval { $dbh->{compare} = 2 };
1381     ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/);
1382
1383     eval { $dbh->{prefix} = 2 };
1384     ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/);
1385
1386 }
1387
1388
1389 #{
1390 #    # recursion detection in btree
1391 #    my %hash ;
1392 #    unlink $Dfile;
1393 #    my $dbh = new DB_File::BTREEINFO ;
1394 #    $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ;
1395 #
1396 #
1397 #    my (%h);
1398 #    ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
1399 #
1400 #    eval {     $hash{1} = 2;
1401 #               $hash{4} = 5;
1402 #        };
1403 #
1404 #    ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
1405 #    {
1406 #        no warnings;
1407 #        untie %hash;
1408 #    }
1409 #    unlink $Dfile;
1410 #}
1411 ok(164,1);
1412 ok(165,1);
1413
1414 {
1415     # Check that two callbacks don't interact
1416     my %hash1 ;
1417     my %hash2 ;
1418     my $h1_count = 0;
1419     my $h2_count = 0;
1420     unlink $Dfile, $Dfile2;
1421     my $dbh1 = new DB_File::BTREEINFO ;
1422     $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ;
1423
1424     my $dbh2 = new DB_File::BTREEINFO ;
1425     $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ;
1426
1427
1428
1429     my (%h);
1430     ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
1431     ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
1432
1433     $hash1{DEFG} = 5;
1434     $hash1{XYZ} = 2;
1435     $hash1{ABCDE} = 5;
1436
1437     $hash2{defg} = 5;
1438     $hash2{xyz} = 2;
1439     $hash2{abcde} = 5;
1440
1441     ok(168, $h1_count > 0);
1442     ok(169, $h1_count == $h2_count);
1443
1444     ok(170, safeUntie \%hash1);
1445     ok(171, safeUntie \%hash2);
1446     unlink $Dfile, $Dfile2;
1447 }
1448
1449 {
1450    # Check that DBM Filter can cope with read-only $_
1451
1452    use warnings ;
1453    use strict ;
1454    my (%h, $db) ;
1455    unlink $Dfile;
1456
1457    ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
1458
1459    $db->filter_fetch_key   (sub { }) ;
1460    $db->filter_store_key   (sub { }) ;
1461    $db->filter_fetch_value (sub { }) ;
1462    $db->filter_store_value (sub { }) ;
1463
1464    $_ = "original" ;
1465
1466    $h{"fred"} = "joe" ;
1467    ok(173, $h{"fred"} eq "joe");
1468
1469    eval { grep { $h{$_} } (1, 2, 3) };
1470    ok (174, ! $@);
1471
1472
1473    # delete the filters
1474    $db->filter_fetch_key   (undef);
1475    $db->filter_store_key   (undef);
1476    $db->filter_fetch_value (undef);
1477    $db->filter_store_value (undef);
1478
1479    $h{"fred"} = "joe" ;
1480
1481    ok(175, $h{"fred"} eq "joe");
1482
1483    ok(176, $db->FIRSTKEY() eq "fred") ;
1484
1485    eval { grep { $h{$_} } (1, 2, 3) };
1486    ok (177, ! $@);
1487
1488    undef $db ;
1489    untie %h;
1490    unlink $Dfile;
1491 }
1492
1493 exit ;