recno.t

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

#!./perl -w

# ID: %I%, %G%   

use strict ;

BEGIN {
    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib' if -d '../lib';
    }
}

use BerkeleyDB; 
use File::Path qw(rmtree);

print "1..218\n";

my %DB_errors = (
    'DB_INCOMPLETE'	=> "DB_INCOMPLETE: Sync was unable to complete",
    'DB_KEYEMPTY'	=> "DB_KEYEMPTY: Non-existent key/data pair",
    'DB_KEYEXIST'	=> "DB_KEYEXIST: Key/data pair already exists",
    'DB_LOCK_DEADLOCK'  => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
    'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
    'DB_NOTFOUND'	=> "DB_NOTFOUND: No matching key/data pair found",
    'DB_OLD_VERSION'	=> "DB_OLDVERSION: Database requires a version upgrade",
    'DB_RUNRECOVERY'	=> "DB_RUNRECOVERY: Fatal error, run database recovery",
) ;

{
    package LexFile ;

    sub new
    {
	my $self = shift ;
	unlink @_ ;
 	bless [ @_ ], $self ;
    }

    sub DESTROY
    {
	my $self = shift ;
	unlink @{ $self } ;
    }
}


sub ok
{
    my $no = shift ;
    my $result = shift ;
 
    print "not " unless $result ;
    print "ok $no\n" ;
}

sub docat
{
    my $file = shift;
    local $/ = undef;
    open(CAT,$file) || die "Cannot open $file:$!";
    my $result = <CAT>;
    close(CAT);
    return $result;
}

sub touch
{
    my $file = shift ;
    open(CAT,">$file") || die "Cannot open $file:$!";
    close(CAT);
}

sub joiner
{
    my $db = shift ;
    my $sep = shift ;
    my ($k, $v) = (0, "") ;
    my @data = () ;

    my $cursor = $db->db_cursor()  or return () ;
    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
          $status == 0 ;
          $status = $cursor->c_get($k, $v, DB_NEXT)) {
	push @data, $v ;
    }

    (scalar(@data), join($sep, @data)) ;
}

sub countRecords
{
   my $db = shift ;
   my ($k, $v) = (0,0) ;
   my ($count) = 0 ;
   my ($cursor) = $db->db_cursor() ;
   #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
#	$status == 0 ;
#	$status = $cursor->c_get($k, $v, DB_NEXT) )
   while ($cursor->c_get($k, $v, DB_NEXT) == 0)
     { ++ $count }

   return $count ;
}

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::Recno  -Stupid => 3 ; ' ;
    ok 1, $@ =~ /unknown key value\(s\) Stupid/  ;

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

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

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

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

# Now check the interface to Recno

{
    my $lex = new LexFile $Dfile ;

    ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile, 
				    -Flags    => DB_CREATE ;

    # Add a k/v pair
    my $value ;
    my $status ;
    ok 7, $db->db_put(1, "some value") == 0  ;
    ok 8, $db->status() == 0 ;
    ok 9, $db->db_get(1, $value) == 0 ;
    ok 10, $value eq "some value" ;
    ok 11, $db->db_put(2, "value") == 0  ;
    ok 12, $db->db_get(2, $value) == 0 ;
    ok 13, $value eq "value" ;
    ok 14, $db->db_del(1) == 0 ;
    ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
    ok 16, $db->status() == DB_KEYEMPTY ;
    ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;

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

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

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

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


    # check that the value of the key  has not been changed by the
    # previous test
    ok 25, $db->db_get(2, $value) == 0 ;
    ok 26, $value eq "value" ;


}


{
    # Check simple env works with a array.
    my $lex = new LexFile $Dfile ;

    my $home = "./fred" ;
    ok 27, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;

    ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
    					 -Home => $home ;

    ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile, 
				    -Env      => $env,
				    -Flags    => DB_CREATE ;

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

 
{
    # cursors

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

    # 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 34, $ret == 0 ;

    # create the cursor
    ok 35, 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 ( $copy{$k} eq $v ) 
            { delete $copy{$k} }
	else
	    { ++ $extras }
    }

    ok 36, $cursor->status() == DB_NOTFOUND ;
    ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
    ok 38, keys %copy == 0 ;
    ok 39, $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 ( $copy{$k} eq $v ) 
            { delete $copy{$k} }
	else
	    { ++ $extras }
    }
    ok 40, $status == DB_NOTFOUND ;
    ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
    ok 42, $cursor->status() == $status ;
    ok 43, $cursor->status() eq $status ;
    ok 44, keys %copy == 0 ;
    ok 45, $extras == 0 ;
}
 
{
    # Tied Array interface

    # full tied array support started in Perl 5.004_57
    # just double check.
    my $FA = 0 ;
    {
        sub try::TIEARRAY { bless [], "try" }
        sub try::FETCHSIZE { $FA = 1 }
        my @a ; 
        tie @a, 'try' ;
        my $a = @a ;
    }

    my $lex = new LexFile $Dfile ;
    my @array ;
    my $db ;
    ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
				    	    -Property => DB_RENUMBER,
				    	    -ArrayBase => 0,
                                            -Flags     => DB_CREATE ;

    ok 47, 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 48, $cursor->status() == DB_NOTFOUND ;
    ok 49, $count == 0 ;

    ok 50, @array == 0 ;

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

    ok 57, (tied @array)->db_del(1) == 0 ;
    ok 58, (tied @array)->status() == 0 ;
    ok 59, ! defined $array[1];
    ok 60, (tied @array)->status() == DB_NOTFOUND ;

    $array[1] = 2 ;
    $array[10] = 20 ;
    $array[1000] = 2000 ;

    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 61, $count == 3 ;
    ok 62, $keys == 1011 ;
    ok 63, $values == 2022 ;

    # unshift
    $FA ? unshift @array, "red", "green", "blue" 
        : $db->unshift("red", "green", "blue" ) ;
    ok 64, $array[1] eq "red" ;
    ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
    ok 66, $k == 1 ;
    ok 67, $v eq "red" ;
    ok 68, $array[2] eq "green" ;
    ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok 70, $k == 2 ;
    ok 71, $v eq "green" ;
    ok 72, $array[3] eq "blue" ;
    ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok 74, $k == 3 ;
    ok 75, $v eq "blue" ;
    ok 76, $array[4] == 2 ;
    ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
    ok 78, $k == 4 ;
    ok 79, $v == 2 ;

    # shift
    ok 80, ($FA ? shift @array : $db->shift()) eq "red" ;
    ok 81, ($FA ? shift @array : $db->shift()) eq "green" ;
    ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ;
    ok 83, ($FA ? shift @array : $db->shift()) == 2 ;

    # push
    $FA ? push @array, "the", "end" 
        : $db->push("the", "end") ;
    ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
    ok 85, $k == 1001 ;
    ok 86, $v eq "end" ;
    ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
    ok 88, $k == 1000 ;
    ok 89, $v eq "the" ;
    ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
    ok 91, $k == 999 ;
    ok 92, $v == 2000 ;

    # pop
    ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ;
    ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ;
    ok 95, ( $FA ? pop @array : $db->pop ) == 2000  ;

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

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

{
    # in-memory file

    my @array ;
    my $fd ;
    my $value ;
    ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ;

    ok 98, $db->db_put(1, "some value") == 0  ;
    ok 99, $db->db_get(1, $value) == 0 ;
    ok 100, $value eq "some value" ;

}
 
{
    # partial
    # check works via API

    my $lex = new LexFile $Dfile ;
    my $value ;
    ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile,
                                      	        -Flags    => DB_CREATE ;

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

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


    # do a partial get
    my ($pon, $off, $len) = $db->partial_set(0,2) ;
    ok 103, ! $pon && $off == 0 && $len == 0 ;
    ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
    ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
    ok 106, $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 107, $pon ;
    ok 108, $off == 0 ;
    ok 109, $len == 2 ;
    ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ;
    ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
    ok 112, $db->db_get(3, $value) == 0 && $value eq "" ;

    # switch of partial mode
    ($pon, $off, $len) = $db->partial_clear() ;
    ok 113, $pon ;
    ok 114, $off == 3 ;
    ok 115, $len == 2 ;
    ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ;
    ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ;
    ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ;

    # now partial put
    $db->partial_set(0,2) ;
    ok 119, $db->db_put(1, "") == 0 ;
    ok 120, $db->db_put(2, "AB") == 0 ;
    ok 121, $db->db_put(3, "XYZ") == 0 ;
    ok 122, $db->db_put(4, "KLM") == 0 ;

    ($pon, $off, $len) = $db->partial_clear() ;
    ok 123, $pon ;
    ok 124, $off == 0 ;
    ok 125, $len == 2 ;
    ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ;
    ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
    ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
    ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ;

    # now partial put
    ($pon, $off, $len) = $db->partial_set(3,2) ;
    ok 130, ! $pon ;
    ok 131, $off == 0 ;
    ok 132, $len == 0 ;
    ok 133, $db->db_put(1, "PPP") == 0 ;
    ok 134, $db->db_put(2, "Q") == 0 ;
    ok 135, $db->db_put(3, "XYZ") == 0 ;
    ok 136, $db->db_put(4, "TU") == 0 ;

    $db->partial_clear() ;
    ok 137, $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
    ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;