queue.t

berkeley db 4.6.21的源码。berkeley db是一个简单的数据库管理系统

#!./perl -w

# ID: %I%, %G%   

use strict ;

use lib 't' ;
use BerkeleyDB; 
use Test::More;
use util(1) ;

plan(skip_all => "Queue needs Berkeley DB 3.3.x or better\n" )
    if $BerkeleyDB::db_version < 3.3;
    
plan tests => 253;


my $Dfile = "dbhash.tmp";
my $Dfile2 = "dbhash2.tmp";
my $Dfile3 = "dbhash3.tmp";
unlink $Dfile;

umask(0) ;


# Check for invalid parameters
{
    # Check for invalid parameters
    my $db ;
    eval ' $db = new BerkeleyDB::Queue  -Stupid => 3 ; ' ;
    ok $@ =~ /unknown key value\(s\) Stupid/  ;

    eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
    ok $@ =~ /unknown key value\(s\) /  ;

    eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;

    eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
    ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;

    my $obj = bless [], "main" ;
    eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
}

# Now check the interface to Queue

{
    my $lex = new LexFile $Dfile ;
    my $rec_len = 10 ;
    my $pad = "x" ;

    ok my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
				    -Flags    => DB_CREATE,
				    -Len      => $rec_len,
				    -Pad      => $pad;

    # Add a k/v pair
    my $value ;
    my $status ;
    ok $db->db_put(1, "some value") == 0  ;
    ok $db->status() == 0 ;
    ok $db->db_get(1, $value) == 0 ;
    ok $value eq fillout("some value", $rec_len, $pad) ;
    ok $db->db_put(2, "value") == 0  ;
    ok $db->db_get(2, $value) == 0 ;
    ok $value eq fillout("value", $rec_len, $pad) ;
    ok $db->db_put(3, "value") == 0  ;
    ok $db->db_get(3, $value) == 0 ;
    ok $value eq fillout("value", $rec_len, $pad) ;
    ok $db->db_del(2) == 0 ;
    ok $db->db_get(2, $value) == DB_KEYEMPTY ;
    ok $db->status() == DB_KEYEMPTY ;
    ok $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;

    ok $db->db_get(7, $value) == DB_NOTFOUND ;
    ok $db->status() == DB_NOTFOUND ;
    ok $db->status() eq $DB_errors{'DB_NOTFOUND'} ;

    ok $db->db_sync() == 0 ;

    # Check NOOVERWRITE will make put fail when attempting to overwrite
    # an existing record.

    ok $db->db_put( 1, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
    ok $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
    ok $db->status() == DB_KEYEXIST ;


    # check that the value of the key  has not been changed by the
    # previous test
    ok $db->db_get(1, $value) == 0 ;
    ok $value eq fillout("some value", $rec_len, $pad) ;


}


{
    # Check simple env works with a array.
    # and pad defaults to space
    my $lex = new LexFile $Dfile ;

    my $home = "./fred" ;
    my $rec_len = 11 ;
    ok my $lexD = new LexDir($home);

    ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,@StdErrFile,
    					 -Home => $home ;
    ok my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
				    -Env      => $env,
				    -Flags    => DB_CREATE,
				    -Len      => $rec_len;

    # Add a k/v pair
    my $value ;
    ok $db->db_put(1, "some value") == 0 ;
    ok $db->db_get(1, $value) == 0 ;
    ok $value eq fillout("some value", $rec_len)  ;
    undef $db ;
    undef $env ;
}

 
{
    # cursors

    my $lex = new LexFile $Dfile ;
    my @array ;
    my ($k, $v) ;
    my $rec_len = 5 ;
    ok my $db = new BerkeleyDB::Queue -Filename  => $Dfile, 
				    	  -ArrayBase => 0,
				    	  -Flags     => DB_CREATE ,
				    	  -Len       => $rec_len;

    # create some data
    my @data =  (
		"red"	,
		"green"	,
		"blue"	,
		) ;

    my $i ;
    my %data ;
    my $ret = 0 ;
    for ($i = 0 ; $i < @data ; ++$i) {
        $ret += $db->db_put($i, $data[$i]) ;
	$data{$i} = $data[$i] ;
    }
    ok $ret == 0 ;

    # create the cursor
    ok my $cursor = $db->db_cursor() ;

    $k = 0 ; $v = "" ;
    my %copy = %data;
    my $extras = 0 ;
    # sequence forwards
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) 
    {
        if ( fillout($copy{$k}, $rec_len) eq $v ) 
            { delete $copy{$k} }
	else
	    { ++ $extras }
    }

    ok $cursor->status() == DB_NOTFOUND ;
    ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
    ok keys %copy == 0 ;
    ok $extras == 0 ;

    # sequence backwards
    %copy = %data ;
    $extras = 0 ;
    my $status ;
    for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
	  $status == 0 ;
    	  $status = $cursor->c_get($k, $v, DB_PREV)) {
        if ( fillout($copy{$k}, $rec_len) eq $v ) 
            { delete $copy{$k} }
	else
	    { ++ $extras }
    }
    ok $status == DB_NOTFOUND ;
    ok $status eq $DB_errors{'DB_NOTFOUND'} ;
    ok $cursor->status() == $status ;
    ok $cursor->status() eq $status ;
    ok keys %copy == 0 ;
    ok $extras == 0 ;
}
 
{
    # Tied Array interface

    my $lex = new LexFile $Dfile ;
    my @array ;
    my $db ;
    my $rec_len = 10 ;
    ok $db = tie @array, 'BerkeleyDB::Queue', -Filename  => $Dfile,
				    	    -ArrayBase => 0,
                                            -Flags     => DB_CREATE ,
				    	    -Len       => $rec_len;

    ok my $cursor = (tied @array)->db_cursor() ;
    # check the database is empty
    my $count = 0 ;
    my ($k, $v) = (0,"") ;
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
	++ $count ;
    }
    ok $cursor->status() == DB_NOTFOUND ;
    ok $count == 0 ;

    ok @array == 0 ;

    # Add a k/v pair
    my $value ;
    $array[1] = "some value";
    ok ((tied @array)->status() == 0) ;
    ok $array[1] eq fillout("some value", $rec_len);
    ok defined $array[1];
    ok ((tied @array)->status() == 0) ;
    ok !defined $array[3];
    ok ((tied @array)->status() == DB_NOTFOUND) ;

    $array[1] = 2 ;
    $array[10] = 20 ;
    $array[100] = 200 ;

    my ($keys, $values) = (0,0);
    $count = 0 ;
    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
	  $status == 0 ;
    	  $status = $cursor->c_get($k, $v, DB_NEXT)) {
        $keys += $k ;
	$values += $v ;
	++ $count ;
    }
    ok $count == 3 ;
    ok $keys == 111 ;
    ok $values == 222 ;

    # unshift isn't allowed
#    eval {
#    	$FA ? unshift @array, "red", "green", "blue" 
#        : $db->unshift("red", "green", "blue" ) ;
#	} ;
#    ok $@ =~ /^unshift is unsupported with Queue databases/ ;	
    $array[0] = "red" ;
    $array[1] = "green" ;
    $array[2] = "blue" ;
    $array[4] = 2 ;
    ok $array[0] eq fillout("red", $rec_len) ;
    ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
    ok $k == 0 ;
    ok $v eq fillout("red", $rec_len) ;
    ok $array[1] eq fillout("green", $rec_len) ;
    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok $k == 1 ;
    ok $v eq fillout("green", $rec_len) ;
    ok $array[2] eq fillout("blue", $rec_len) ;
    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok $k == 2 ;
    ok $v eq fillout("blue", $rec_len) ;
    ok $array[4] == 2 ;
    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok $k == 4 ;
    ok $v == 2 ;

    # shift
    ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
    ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
    ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
    ok (($FA ? shift @array : $db->shift()) == 2) ;

    # push
    $FA ? push @array, "the", "end" 
        : $db->push("the", "end") ;
    ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
    ok $k == 102 ;
    ok $v eq fillout("end", $rec_len) ;
    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
    ok $k == 101 ;
    ok $v eq fillout("the", $rec_len) ;
    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
    ok $k == 100 ;
    ok $v == 200 ;

    # pop
    ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
    ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
    ok (( $FA ? pop @array : $db->pop ) == 200)  ;

    # now clear the array 
    $FA ? @array = () 
        : $db->clear() ;
    ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;

    undef $cursor ;
    undef $db ;
    untie @array ;
}

{
    # in-memory file

    my @array ;
    my $fd ;
    my $value ;
    my $rec_len = 15 ;
    ok my $db = tie @array, 'BerkeleyDB::Queue',
				    	    -Len       => $rec_len;

    ok $db->db_put(1, "some value") == 0  ;
    ok $db->db_get(1, $value) == 0 ;
    ok $value eq fillout("some value", $rec_len) ;

}
 
{
    # partial
    # check works via API

    my $lex = new LexFile $Dfile ;
    my $value ;
    my $rec_len = 8 ;
    ok my $db = new BerkeleyDB::Queue  -Filename => $Dfile,
                                      	    -Flags    => DB_CREATE ,
				    	    -Len      => $rec_len,
				    	    -Pad      => " " ;

    # create some data
    my @data =  (
		"",
		"boat",
		"house",
		"sea",
		) ;

    my $ret = 0 ;
    my $i ;
    for ($i = 0 ; $i < @data ; ++$i) {
        my $r = $db->db_put($i, $data[$i]) ;
        $ret += $r ;
    }
    ok $ret == 0 ;

    # do a partial get
    my ($pon, $off, $len) = $db->partial_set(0,2) ;
    ok ! $pon && $off == 0 && $len == 0 ;
    ok $db->db_get(1, $value) == 0 && $value eq "bo" ;
    ok $db->db_get(2, $value) == 0 && $value eq "ho" ;
    ok $db->db_get(3, $value) == 0 && $value eq "se" ;

    # do a partial get, off end of data
    ($pon, $off, $len) = $db->partial_set(3,2) ;
    ok $pon ;
    ok $off == 0 ;
    ok $len == 2 ;
    ok $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
    ok $db->db_get(2, $value) == 0 && $value eq "se" ;
    ok $db->db_get(3, $value) == 0 && $value eq "  " ;

    # switch of partial mode
    ($pon, $off, $len) = $db->partial_clear() ;
    ok $pon ;
    ok $off == 3 ;
    ok $len == 2 ;
    ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
    ok $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
    ok $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;

    # now partial put
    $db->partial_set(0,2) ;
    ok $db->db_put(1, "") != 0 ;
    ok $db->db_put(2, "AB") == 0 ;
    ok $db->db_put(3, "XY") == 0 ;
    ok $db->db_put(4, "KLM") != 0 ;
    ok $db->db_put(4, "KL") == 0 ;

    ($pon, $off, $len) = $db->partial_clear() ;
    ok $pon ;
    ok $off == 0 ;
    ok $len == 2 ;
    ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
    ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
    ok $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
    ok $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;

    # now partial put
    ($pon, $off, $len) = $db->partial_set(3,2) ;
    ok ! $pon ;
    ok $off == 0 ;
    ok $len == 0 ;
    ok $db->db_put(1, "PP") == 0 ;
    ok $db->db_put(2, "Q") != 0 ;
    ok $db->db_put(3, "XY") == 0 ;
    ok $db->db_put(4, "TU") == 0 ;

    $db->partial_clear() ;
    ok $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
    ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
    ok $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
    ok $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
}

{
    # partial
    # check works via tied array 

    my $lex = new LexFile $Dfile ;
    my @array ;
    my $value ;
    my $rec_len = 8 ;
    ok my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
                                      	        -Flags    => DB_CREATE ,
				    	        -Len       => $rec_len,
				    	        -Pad       => " " ;

    # create some data
    my @data =  (
		"",
		"boat",
		"house",
		"sea",
		) ;

    my $i ;
    my $status = 0 ;
    for ($i = 1 ; $i < @data ; ++$i) {
	$array[$i] = $data[$i] ;
	$status += $db->status() ;