"Fossies" - the Fresh Open Source Software Archive

Member "DB_File-1.852/t/db-btree.t" (21 Apr 2019, 37002 Bytes) of package /linux/privat/DB_File-1.852.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the last Fossies "Diffs" side-by-side code changes report for "db-btree.t": 1.841_vs_1.842.

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