db-btree.t

关于Berkelay数据库的共享源码

    @list = $x->get_dup("Smith") ;
    print "Smith =>	[@list]\n" ;
 
    @list = $x->get_dup("Dog") ;
    print "Dog =>	[@list]\n" ; 
 
    undef $x ;
    untie %h ;
  }

  ok(150, docat_del($file) eq <<'EOM') ;
Wall occurred 3 times
Larry is there
There are 2 Brick Walls
Wall =>	[Brick Brick Larry]
Smith =>	[John]
Dog =>	[]
EOM

  {
    my $redirect = new Redirect $file ;

    # BTREE example 5
    ###

    use warnings FATAL => qw(all) ;
    use strict ;
    use DB_File ;
 
    my ($filename, $x, %h, $found);

    $filename = "tree" ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";

    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
    print "Larry Wall is $found there\n" ;
    
    $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; 
    print "Harry Wall is $found there\n" ;
    
    undef $x ;
    untie %h ;
  }

  ok(151, docat_del($file) eq <<'EOM') ;
Larry Wall is  there
Harry Wall is not there
EOM

  {
    my $redirect = new Redirect $file ;

    # BTREE example 6
    ###

    use warnings FATAL => qw(all) ;
    use strict ;
    use DB_File ;
 
    my ($filename, $x, %h, $found);

    $filename = "tree" ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";

    $x->del_dup("Wall", "Larry") ;

    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
    print "Larry Wall is $found there\n" ;
    
    undef $x ;
    untie %h ;

    unlink $filename ;
  }

  ok(152, docat_del($file) eq <<'EOM') ;
Larry Wall is not there
EOM

  {
    my $redirect = new Redirect $file ;

    # BTREE example 7
    ###

    use warnings FATAL => qw(all) ;
    use strict ;
    use DB_File ;
    use Fcntl ;

    my ($filename, $x, %h, $st, $key, $value);

    sub match
    {
        my $key = shift ;
        my $value = 0;
        my $orig_key = $key ;
        $x->seq($key, $value, R_CURSOR) ;
        print "$orig_key\t-> $key\t-> $value\n" ;
    }

    $filename = "tree" ;
    unlink $filename ;

    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
        or die "Cannot open $filename: $!\n";
 
    # Add some key/value pairs to the file
    $h{'mouse'} = 'mickey' ;
    $h{'Wall'} = 'Larry' ;
    $h{'Walls'} = 'Brick' ; 
    $h{'Smith'} = 'John' ;
 

    $key = $value = 0 ;
    print "IN ORDER\n" ;
    for ($st = $x->seq($key, $value, R_FIRST) ;
	 $st == 0 ;
         $st = $x->seq($key, $value, R_NEXT) )
	
      {  print "$key	-> $value\n" }
 
    print "\nPARTIAL MATCH\n" ;

    match "Wa" ;
    match "A" ;
    match "a" ;

    undef $x ;
    untie %h ;

    unlink $filename ;

  }

  ok(153, docat_del($file) eq <<'EOM') ;
IN ORDER
Smith	-> John
Wall	-> Larry
Walls	-> Brick
mouse	-> mickey

PARTIAL MATCH
Wa	-> Wall	-> Larry
A	-> Smith	-> John
a	-> mouse	-> mickey
EOM

}

#{
#   # R_SETCURSOR
#   use strict ;
#   my (%h, $db) ;
#   unlink $Dfile;
#
#   ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
#
#   $h{abc} = 33 ;
#   my $k = "newest" ;
#   my $v = 44 ;
#   my $status = $db->put($k, $v, R_SETCURSOR) ;
#   print "status = [$status]\n" ;
#   ok(157, $status == 0) ;
#   $status = $db->del($k, R_CURSOR) ;
#   print "status = [$status]\n" ;
#   ok(158, $status == 0) ;
#   $k = "newest" ;
#   ok(159, $db->get($k, $v, R_CURSOR)) ;
#
#   ok(160, keys %h == 1) ;
#   
#   undef $db ;
#   untie %h;
#   unlink $Dfile;
#}

{
    # Bug ID 20001013.009
    #
    # test that $hash{KEY} = undef doesn't produce the warning
    #     Use of uninitialized value in null operation 
    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
    
    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
	or die "Can't open file: $!\n" ;
    $h{ABC} = undef;
    ok(154, $a eq "") ;
    untie %h ;
    unlink $Dfile;
}

{
    # test that %hash = () doesn't produce the warning
    #     Argument "" isn't numeric in entersub
    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
    
    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
	or die "Can't open file: $!\n" ;
    %h = (); ;
    ok(155, $a eq "") ;
    untie %h ;
    unlink $Dfile;
}

{
    # When iterating over a tied hash using "each", the key passed to FETCH
    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
    # key in FETCH via a filter_fetch_key method we need to check that the
    # modified key doesn't get passed to NEXTKEY.
    # Also Test "keys" & "values" while we are at it.

    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my $bad_key = 0 ;
    my %h = () ;
    my $db ;
    ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;

    $h{'Alpha_ABC'} = 2 ;
    $h{'Alpha_DEF'} = 5 ;

    ok(157, $h{'Alpha_ABC'} == 2);
    ok(158, $h{'Alpha_DEF'} == 5);

    my ($k, $v) = ("","");
    while (($k, $v) = each %h) {}
    ok(159, $bad_key == 0);

    $bad_key = 0 ;
    foreach $k (keys %h) {}
    ok(160, $bad_key == 0);

    $bad_key = 0 ;
    foreach $v (values %h) {}
    ok(161, $bad_key == 0);

    undef $db ;
    untie %h ;
    unlink $Dfile;
}

{
    # now an error to pass 'compare' a non-code reference
    my $dbh = new DB_File::BTREEINFO ;

    eval { $dbh->{compare} = 2 };
    ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/);

    eval { $dbh->{prefix} = 2 };
    ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/);

}


#{
#    # recursion detection in btree
#    my %hash ;
#    unlink $Dfile;
#    my $dbh = new DB_File::BTREEINFO ;
#    $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ;
# 
# 
#    my (%h);
#    ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
#
#    eval {	$hash{1} = 2;
#    		$hash{4} = 5;
#	 };
#
#    ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
#    {
#        no warnings;
#        untie %hash;
#    }
#    unlink $Dfile;
#}
ok(164,1);
ok(165,1);

{
    # Check that two callbacks don't interact
    my %hash1 ;
    my %hash2 ;
    my $h1_count = 0;
    my $h2_count = 0;
    unlink $Dfile, $Dfile2;
    my $dbh1 = new DB_File::BTREEINFO ;
    $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; 

    my $dbh2 = new DB_File::BTREEINFO ;
    $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; 
 
 
 
    my (%h);
    ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
    ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );

    $hash1{DEFG} = 5;
    $hash1{XYZ} = 2;
    $hash1{ABCDE} = 5;

    $hash2{defg} = 5;
    $hash2{xyz} = 2;
    $hash2{abcde} = 5;

    ok(168, $h1_count > 0);
    ok(169, $h1_count == $h2_count);

    ok(170, safeUntie \%hash1);
    ok(171, safeUntie \%hash2);
    unlink $Dfile, $Dfile2;
}

{
   # Check that DBM Filter can cope with read-only $_

   use warnings ;
   use strict ;
   my (%h, $db) ;
   unlink $Dfile;

   ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );

   $db->filter_fetch_key   (sub { }) ;
   $db->filter_store_key   (sub { }) ;
   $db->filter_fetch_value (sub { }) ;
   $db->filter_store_value (sub { }) ;

   $_ = "original" ;

   $h{"fred"} = "joe" ;
   ok(173, $h{"fred"} eq "joe");

   eval { grep { $h{$_} } (1, 2, 3) };
   ok (174, ! $@);


   # delete the filters
   $db->filter_fetch_key   (undef);
   $db->filter_store_key   (undef);
   $db->filter_fetch_value (undef);
   $db->filter_store_value (undef);

   $h{"fred"} = "joe" ;

   ok(175, $h{"fred"} eq "joe");

   ok(176, $db->FIRSTKEY() eq "fred") ;
   
   eval { grep { $h{$_} } (1, 2, 3) };
   ok (177, ! $@);

   undef $db ;
   untie %h;
   unlink $Dfile;
}

{
   # Check low-level API works with filter

   use warnings ;
   use strict ;
   my (%h, $db) ;
   my $Dfile = "xxy.db";
   unlink $Dfile;

   ok(178, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );


   $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
   $db->filter_store_key   (sub { $_ = pack("i", $_) } );
   $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
   $db->filter_store_value (sub { $_ = pack("i", $_) } );

   $_ = 'fred';

   my $key = 22 ;
   my $value = 34 ;

   $db->put($key, $value) ;
   ok 179, $key == 22;
   ok 180, $value == 34 ;
   ok 181, $_ eq 'fred';
   #print "k [$key][$value]\n" ;

   my $val ;
   $db->get($key, $val) ;
   ok 182, $key == 22;
   ok 183, $val == 34 ;
   ok 184, $_ eq 'fred';

   $key = 51 ;
   $value = 454;
   $h{$key} = $value ;
   ok 185, $key == 51;
   ok 186, $value == 454 ;
   ok 187, $_ eq 'fred';

   undef $db ;
   untie %h;
   unlink $Dfile;
}



{
    # Regression Test for bug 30237
    # Check that substr can be used in the key to db_put
    # and that db_put does not trigger the warning
    # 
    #     Use of uninitialized value in subroutine entry


    use warnings ;
    use strict ;
    my (%h, $db) ;
    my $Dfile = "xxy.db";
    unlink $Dfile;

    ok(188, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ));

    my $warned = '';
    local $SIG{__WARN__} = sub {$warned = $_[0]} ;

    # db-put with substr of key
    my %remember = () ;
    for my $ix ( 10 .. 12 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $db->put(substr($key,0), $value) ;
    }

    ok 189, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # db-put with substr of value
    $warned = '';
    for my $ix ( 20 .. 22 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $db->put($key, substr($value,0)) ;
    }

    ok 190, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # via the tied hash is not a problem, but check anyway
    # substr of key
    $warned = '';
    for my $ix ( 30 .. 32 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $h{substr($key,0)} = $value ;
    }

    ok 191, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # via the tied hash is not a problem, but check anyway
    # substr of value
    $warned = '';
    for my $ix ( 40 .. 42 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $h{$key} = substr($value,0) ;
    }

    ok 192, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    my %bad = () ;
    $key = '';
    for ($status = $db->seq($key, $value, R_FIRST ) ;
         $status == 0 ;
         $status = $db->seq($key, $value, R_NEXT ) ) {

        #print "# key [$key] value [$value]\n" ;
        if (defined $remember{$key} && defined $value && 
             $remember{$key} eq $value) {
            delete $remember{$key} ;
        }
        else {
            $bad{$key} = $value ;
        }
    }
    
    ok 193, keys %bad == 0 ;
    ok 194, keys %remember == 0 ;

    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;

    # Make sure this fix does not break code to handle an undef key
    # Berkeley DB undef key is bron between versions 2.3.16 and 
    my $value = 'fred';
    $warned = '';
    $db->put(undef, $value) ;
    ok 195, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
    print "# db_ver $DB_File::db_ver\n";
    $value = '' ;
    $db->get(undef, $value) ;
    ok 196, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
    ok 197, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    undef $db ;
    untie %h;
    unlink $Dfile;
}
exit ;