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