cpan/DB_File/t/db-btree.t

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