hash.t

介绍：MySQL是比较出名的数据库软件

    $db->partial_clear() ;
    ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ;
    ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
    ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
    ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ;

    # now partial put
    $db->partial_set(3,2) ;
    ok 109, $db->db_put("red", "PPP") == 0 ;
    ok 110, $db->db_put("green", "Q") == 0 ;
    ok 111, $db->db_put("blue", "XYZ") == 0 ;
    ok 112, $db->db_put("new", "--") == 0 ;

    ($pon, $off, $len) = $db->partial_clear() ;
    ok 113, $pon ;
    ok 114, $off == 3 ;
    ok 115, $len == 2 ;
    ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
    ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
    ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
    ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
}

{
    # partial
    # check works via tied hash 

    my $lex = new LexFile $Dfile ;
    my %hash ;
    my $value ;
    ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
                                      	       -Flags    => DB_CREATE ;

    # create some data
    my %data =  (
		"red"	=> "boat",
		"green"	=> "house",
		"blue"	=> "sea",
		) ;

    while (my ($k, $v) = each %data) {
	$hash{$k} = $v ;
    }


    # do a partial get
    $db->partial_set(0,2) ;
    ok 121, $hash{"red"} eq "bo" ;
    ok 122, $hash{"green"} eq "ho" ;
    ok 123, $hash{"blue"}  eq "se" ;

    # do a partial get, off end of data
    $db->partial_set(3,2) ;
    ok 124, $hash{"red"} eq "t" ;
    ok 125, $hash{"green"} eq "se" ;
    ok 126, $hash{"blue"} eq "" ;

    # switch of partial mode
    $db->partial_clear() ;
    ok 127, $hash{"red"} eq "boat" ;
    ok 128, $hash{"green"} eq "house" ;
    ok 129, $hash{"blue"} eq "sea" ;

    # now partial put
    $db->partial_set(0,2) ;
    ok 130, $hash{"red"} = "" ;
    ok 131, $hash{"green"} = "AB" ;
    ok 132, $hash{"blue"} = "XYZ" ;
    ok 133, $hash{"new"} = "KLM" ;

    $db->partial_clear() ;
    ok 134, $hash{"red"} eq "at" ;
    ok 135, $hash{"green"} eq "ABuse" ;
    ok 136, $hash{"blue"} eq "XYZa" ;
    ok 137, $hash{"new"} eq "KLM" ;

    # now partial put
    $db->partial_set(3,2) ;
    ok 138, $hash{"red"} = "PPP" ;
    ok 139, $hash{"green"} = "Q" ;
    ok 140, $hash{"blue"} = "XYZ" ;
    ok 141, $hash{"new"} = "TU" ;

    $db->partial_clear() ;
    ok 142, $hash{"red"} eq "at\0PPP" ;
    ok 143, $hash{"green"} eq "ABuQ" ;
    ok 144, $hash{"blue"} eq "XYZXYZ" ;
    ok 145, $hash{"new"} eq "KLMTU" ;
}

{
    # transaction

    my $lex = new LexFile $Dfile ;
    my %hash ;
    my $value ;

    my $home = "./fred" ;
    rmtree $home if -e $home ;
    ok 146, mkdir($home, 0777) ;
    ok 147, my $env = new BerkeleyDB::Env -Home => $home,
				     -Flags => DB_CREATE|DB_INIT_TXN|
					  	DB_INIT_MPOOL|DB_INIT_LOCK ;
    ok 148, my $txn = $env->txn_begin() ;
    ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
                                      	       	-Flags     => DB_CREATE ,
					       	-Env 	   => $env,
					    	-Txn	   => $txn  ;

    
    # create some data
    my %data =  (
		"red"	=> "boat",
		"green"	=> "house",
		"blue"	=> "sea",
		) ;

    my $ret = 0 ;
    while (my ($k, $v) = each %data) {
        $ret += $db1->db_put($k, $v) ;
    }
    ok 150, $ret == 0 ;

    # should be able to see all the records

    ok 151, my $cursor = $db1->db_cursor() ;
    my ($k, $v) = ("", "") ;
    my $count = 0 ;
    # sequence forwards
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
        ++ $count ;
    }
    ok 152, $count == 3 ;
    undef $cursor ;

    # now abort the transaction
    ok 153, $txn->txn_abort() == 0 ;

    # there shouldn't be any records in the database
    $count = 0 ;
    # sequence forwards
    ok 154, $cursor = $db1->db_cursor() ;
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
        ++ $count ;
    }
    ok 155, $count == 0 ;

    undef $txn ;
    undef $cursor ;
    undef $db1 ;
    undef $env ;
    untie %hash ;
    rmtree $home ;
}


{
    # DB_DUP

    my $lex = new LexFile $Dfile ;
    my %hash ;
    ok 156, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
				      -Property  => DB_DUP,
                                      -Flags    => DB_CREATE ;

    $hash{'Wall'} = 'Larry' ;
    $hash{'Wall'} = 'Stone' ;
    $hash{'Smith'} = 'John' ;
    $hash{'Wall'} = 'Brick' ;
    $hash{'Wall'} = 'Brick' ;
    $hash{'mouse'} = 'mickey' ;

    ok 157, keys %hash == 6 ;

    # create a cursor
    ok 158, my $cursor = $db->db_cursor() ;

    my $key = "Wall" ;
    my $value ;
    ok 159, $cursor->c_get($key, $value, DB_SET) == 0 ;
    ok 160, $key eq "Wall" && $value eq "Larry" ;
    ok 161, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 162, $key eq "Wall" && $value eq "Stone" ;
    ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 164, $key eq "Wall" && $value eq "Brick" ;
    ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 166, $key eq "Wall" && $value eq "Brick" ;

    #my $ref = $db->db_stat() ; 
    #ok 143, $ref->{bt_flags} | DB_DUP ;

    # test DB_DUP_NEXT
    my ($k, $v) = ("Wall", "") ;
    ok 167, $cursor->c_get($k, $v, DB_SET) == 0 ;
    ok 168, $k eq "Wall" && $v eq "Larry" ;
    ok 169, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
    ok 170, $k eq "Wall" && $v eq "Stone" ;
    ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
    ok 172, $k eq "Wall" && $v eq "Brick" ;
    ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
    ok 174, $k eq "Wall" && $v eq "Brick" ;
    ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
    

    undef $db ;
    undef $cursor ;
    untie %hash ;

}

{
    # DB_DUP & DupCompare
    my $lex = new LexFile $Dfile, $Dfile2;
    my ($key, $value) ;
    my (%h, %g) ;
    my @Keys   = qw( 0123 9 12 -1234 9 987654321 9 def  ) ; 
    my @Values = qw( 1    11 3   dd   x abc      2 0    ) ; 

    ok 176, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile, 
				     -DupCompare   => sub { $_[0] cmp $_[1] },
				     -Property  => DB_DUP|DB_DUPSORT,
				     -Flags    => DB_CREATE ;

    ok 177, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2, 
				     -DupCompare   => sub { $_[0] <=> $_[1] },
				     -Property  => DB_DUP|DB_DUPSORT,
				     -Flags    => DB_CREATE ;

    foreach (@Keys) {
        local $^W = 0 ;
	my $value = shift @Values ;
        $h{$_} = $value ; 
        $g{$_} = $value ;
    }

    ok 178, my $cursor = (tied %h)->db_cursor() ;
    $key = 9 ; $value = "";
    ok 179, $cursor->c_get($key, $value, DB_SET) == 0 ;
    ok 180, $key == 9 && $value eq 11 ;
    ok 181, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 182, $key == 9 && $value == 2 ;
    ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 184, $key == 9 && $value eq "x" ;

    $cursor = (tied %g)->db_cursor() ;
    $key = 9 ;
    ok 185, $cursor->c_get($key, $value, DB_SET) == 0 ;
    ok 186, $key == 9 && $value eq "x" ;
    ok 187, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 188, $key == 9 && $value == 2 ;
    ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
    ok 190, $key == 9 && $value  == 11 ;


}

{
    # get_dup etc
    my $lex = new LexFile $Dfile;
    my %hh ;

    ok 191, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile, 
				     -DupCompare   => sub { $_[0] cmp $_[1] },
				     -Property  => DB_DUP,
				     -Flags    => DB_CREATE ;

    $hh{'Wall'} = 'Larry' ;
    $hh{'Wall'} = 'Stone' ; # Note the duplicate key
    $hh{'Wall'} = 'Brick' ; # Note the duplicate key
    $hh{'Smith'} = 'John' ;
    $hh{'mouse'} = 'mickey' ;
    
    # first work in scalar context
    ok 192, scalar $YY->get_dup('Unknown') == 0 ;
    ok 193, scalar $YY->get_dup('Smith') == 1 ;
    ok 194, scalar $YY->get_dup('Wall') == 3 ;
    
    # now in list context
    my @unknown = $YY->get_dup('Unknown') ;
    ok 195, "@unknown" eq "" ;
    
    my @smith = $YY->get_dup('Smith') ;
    ok 196, "@smith" eq "John" ;
    
    {
        my @wall = $YY->get_dup('Wall') ;
        my %wall ;
        @wall{@wall} = @wall ;
        ok 197, (@wall == 3 && $wall{'Larry'} 
			&& $wall{'Stone'} && $wall{'Brick'});
    }
    
    # hash
    my %unknown = $YY->get_dup('Unknown', 1) ;
    ok 198, keys %unknown == 0 ;
    
    my %smith = $YY->get_dup('Smith', 1) ;
    ok 199, keys %smith == 1 && $smith{'John'} ;
    
    my %wall = $YY->get_dup('Wall', 1) ;
    ok 200, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
    		&& $wall{'Brick'} == 1 ;
    
    undef $YY ;
    untie %hh ;

}

{
   # sub-class test

   package Another ;

   use strict ;

   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
   print FILE <<'EOM' ;

   package SubDB ;

   use strict ;
   use vars qw( @ISA @EXPORT) ;

   require Exporter ;
   use BerkeleyDB;
   @ISA=qw(BerkeleyDB::Hash);
   @EXPORT = @BerkeleyDB::EXPORT ;

   sub db_put { 
	my $self = shift ;
        my $key = shift ;
        my $value = shift ;
        $self->SUPER::db_put($key, $value * 3) ;
   }

   sub db_get { 
	my $self = shift ;
        $self->SUPER::db_get($_[0], $_[1]) ;
	$_[1] -= 2 ;
   }

   sub A_new_method
   {
	my $self = shift ;
        my $key = shift ;
        my $value = $self->FETCH($key) ;
	return "[[$value]]" ;
   }

   1 ;
EOM

    close FILE ;

    BEGIN { push @INC, '.'; }    
    eval 'use SubDB ; ';
    main::ok 201, $@ eq "" ;
    my %h ;
    my $X ;
    eval '
	$X = tie(%h, "SubDB", -Filename => "dbhash.tmp", 
			-Flags => DB_CREATE,
			-Mode => 0640 );
	' ;

    main::ok 202, $@ eq "" ;

    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
    main::ok 203, $@ eq "" ;
    main::ok 204, $ret == 7 ;

    my $value = 0;
    $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
    main::ok 205, $@ eq "" ;
    main::ok 206, $ret == 10 ;

    $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
    main::ok 207, $@ eq ""  ;
    main::ok 208, $ret == 1 ;

    $ret = eval '$X->A_new_method("joe") ' ;
    main::ok 209, $@ eq "" ;
    main::ok 210, $ret eq "[[10]]" ;

    unlink "SubDB.pm", "dbhash.tmp" ;

}