t/lib/db-btree.t

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