Category

Development Platform
Home > SourceCode/Document > Database system > MySQL > View Code
btree.t
Package: mysql-3.23.35.tar.gz　[view]
Upload User: tsgydb
Upload Date: 2007-04-14
Package Size: 10674k
Code Size: 25k
Category:

MySQL

Development Platform:

Visual C++

btree.t：Code Content
  1. #!./perl -w
  3. # ID: %I%, %G%   
  5. use strict ;
  7. BEGIN {
  8.     unless(grep /blib/, @INC) {
  9.         chdir 't' if -d 't';
  10.         @INC = '../lib' if -d '../lib';
  11.     }
  12. }
  14. #use Config;
  15. #
  16. #BEGIN {
  17. #    if(-d "lib" && -f "TEST") {
  18. #        if ($Config{'extensions'} !~ /bBerkeleyDBb/ ) {
  19. #            print "1..74n";
  20. #            exit 0;
  21. #        }
  22. #    }
  23. #}
  25. use BerkeleyDB; 
  26. use File::Path qw(rmtree);
  28. print "1..243n";
  30. my %DB_errors = (
  31.     'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
  32.     'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
  33.     'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
  34.     'DB_LOCK_DEADLOCK'  => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
  35.     'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
  36.     'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
  37.     'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade",
  38.     'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery",
  39. ) ;
  41. {
  42.     package LexFile ;
  44.     sub new
  45.     {
  46. my $self = shift ;
  47. unlink @_ ;
  48.   bless [ @_ ], $self ;
  49.     }
  51.     sub DESTROY
  52.     {
  53. my $self = shift ;
  54. unlink @{ $self } ;
  55.     }
  56. }
  58. sub ok
  59. {
  60.     my $no = shift ;
  61.     my $result = shift ;
  62.  
  63.     print "not " unless $result ;
  64.     print "ok $non" ;
  65. }
  67. my $Dfile = "dbhash.tmp";
  68. my $Dfile2 = "dbhash2.tmp";
  69. my $Dfile3 = "dbhash3.tmp";
  70. unlink $Dfile;
  72. umask(0) ;
  75. # Check for invalid parameters
  76. {
  77.     # Check for invalid parameters
  78.     my $db ;
  79.     eval ' $db = new BerkeleyDB::Btree  -Stupid => 3 ; ' ;
  80.     ok 1, $@ =~ /unknown key value(s) Stupid/  ;
  82.     eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
  83.     ok 2, $@ =~ /unknown key value(s) (Bad |Stupid ){2}/  ;
  85.     eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ;
  86.     ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  88.     eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ;
  89.     ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
  91.     my $obj = bless [], "main" ;
  92.     eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ;
  93.     ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  94. }
  96. # Now check the interface to Btree
  98. {
  99.     my $lex = new LexFile $Dfile ;
  101.     ok 6, my $db = new BerkeleyDB::Btree -Filename => $Dfile, 
  102.     -Flags    => DB_CREATE ;
  104.     # Add a k/v pair
  105.     my $value ;
  106.     my $status ;
  107.     ok 7, $db->db_put("some key", "some value") == 0  ;
  108.     ok 8, $db->status() == 0 ;
  109.     ok 9, $db->db_get("some key", $value) == 0 ;
  110.     ok 10, $value eq "some value" ;
  111.     ok 11, $db->db_put("key", "value") == 0  ;
  112.     ok 12, $db->db_get("key", $value) == 0 ;
  113.     ok 13, $value eq "value" ;
  114.     ok 14, $db->db_del("some key") == 0 ;
  115.     ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
  116.     ok 16, $db->status() == DB_NOTFOUND ;
  117.     ok 17, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
  119.     ok 18, $db->db_sync() == 0 ;
  121.     # Check NOOVERWRITE will make put fail when attempting to overwrite
  122.     # an existing record.
  124.     ok 19, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
  125.     ok 20, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
  126.     ok 21, $db->status() == DB_KEYEXIST ;
  129.     # check that the value of the key  has not been changed by the
  130.     # previous test
  131.     ok 22, $db->db_get("key", $value) == 0 ;
  132.     ok 23, $value eq "value" ;
  134.     # test DB_GET_BOTH
  135.     my ($k, $v) = ("key", "value") ;
  136.     ok 24, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
  138.     ($k, $v) = ("key", "fred") ;
  139.     ok 25, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  141.     ($k, $v) = ("another", "value") ;
  142.     ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  145. }
  147. {
  148.     # Check simple env works with a hash.
  149.     my $lex = new LexFile $Dfile ;
  151.     my $home = "./fred" ;
  152.     ok 27, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;
  154.     ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
  155.       -Home => $home ;
  156.     ok 29, my $db = new BerkeleyDB::Btree -Filename => $Dfile, 
  157.     -Env      => $env,
  158.     -Flags    => DB_CREATE ;
  160.     # Add a k/v pair
  161.     my $value ;
  162.     ok 30, $db->db_put("some key", "some value") == 0 ;
  163.     ok 31, $db->db_get("some key", $value) == 0 ;
  164.     ok 32, $value eq "some value" ;
  165.     undef $db ;
  166.     undef $env ;
  167.     rmtree $home ;
  168. }
  170.  
  171. {
  172.     # cursors
  174.     my $lex = new LexFile $Dfile ;
  175.     my %hash ;
  176.     my ($k, $v) ;
  177.     ok 33, my $db = new BerkeleyDB::Btree -Filename => $Dfile, 
  178.      -Flags    => DB_CREATE ;
  180.     # create some data
  181.     my %data =  (
  182. "red" => 2,
  183. "green" => "house",
  184. "blue" => "sea",
  185. ) ;
  187.     my $ret = 0 ;
  188.     while (($k, $v) = each %data) {
  189.         $ret += $db->db_put($k, $v) ;
  190.     }
  191.     ok 34, $ret == 0 ;
  193.     # create the cursor
  194.     ok 35, my $cursor = $db->db_cursor() ;
  196.     $k = $v = "" ;
  197.     my %copy = %data ;
  198.     my $extras = 0 ;
  199.     # sequence forwards
  200.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  201.         if ( $copy{$k} eq $v ) 
  202.             { delete $copy{$k} }
  203. else
  204.     { ++ $extras }
  205.     }
  206.     ok 36, $cursor->status() == DB_NOTFOUND ;
  207.     ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'};
  208.     ok 38, keys %copy == 0 ;
  209.     ok 39, $extras == 0 ;
  211.     # sequence backwards
  212.     %copy = %data ;
  213.     $extras = 0 ;
  214.     my $status ;
  215.     for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
  216.   $status == 0 ;
  217.        $status = $cursor->c_get($k, $v, DB_PREV)) {
  218.         if ( $copy{$k} eq $v ) 
  219.             { delete $copy{$k} }
  220. else
  221.     { ++ $extras }
  222.     }
  223.     ok 40, $status == DB_NOTFOUND ;
  224.     ok 41, $status eq $DB_errors{'DB_NOTFOUND'};
  225.     ok 42, $cursor->status() == $status ;
  226.     ok 43, $cursor->status() eq $status ;
  227.     ok 44, keys %copy == 0 ;
  228.     ok 45, $extras == 0 ;
  230.     ($k, $v) = ("green", "house") ;
  231.     ok 46, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
  233.     ($k, $v) = ("green", "door") ;
  234.     ok 47, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  236.     ($k, $v) = ("black", "house") ;
  237.     ok 48, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  239. }
  240.  
  241. {
  242.     # Tied Hash interface
  244.     my $lex = new LexFile $Dfile ;
  245.     my %hash ;
  246.     ok 49, tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
  247.                                       -Flags    => DB_CREATE ;
  249.     # check "each" with an empty database
  250.     my $count = 0 ;
  251.     while (my ($k, $v) = each %hash) {
  252. ++ $count ;
  253.     }
  254.     ok 50, (tied %hash)->status() == DB_NOTFOUND ;
  255.     ok 51, $count == 0 ;
  257.     # Add a k/v pair
  258.     my $value ;
  259.     $hash{"some key"} = "some value";
  260.     ok 52, (tied %hash)->status() == 0 ;
  261.     ok 53, $hash{"some key"} eq "some value";
  262.     ok 54, defined $hash{"some key"} ;
  263.     ok 55, (tied %hash)->status() == 0 ;
  264.     ok 56, exists $hash{"some key"} ;
  265.     ok 57, !defined $hash{"jimmy"} ;
  266.     ok 58, (tied %hash)->status() == DB_NOTFOUND ;
  267.     ok 59, !exists $hash{"jimmy"} ;
  268.     ok 60, (tied %hash)->status() == DB_NOTFOUND ;
  270.     delete $hash{"some key"} ;
  271.     ok 61, (tied %hash)->status() == 0 ;
  272.     ok 62, ! defined $hash{"some key"} ;
  273.     ok 63, (tied %hash)->status() == DB_NOTFOUND ;
  274.     ok 64, ! exists $hash{"some key"} ;
  275.     ok 65, (tied %hash)->status() == DB_NOTFOUND ;
  277.     $hash{1} = 2 ;
  278.     $hash{10} = 20 ;
  279.     $hash{1000} = 2000 ;
  281.     my ($keys, $values) = (0,0);
  282.     $count = 0 ;
  283.     while (my ($k, $v) = each %hash) {
  284.         $keys += $k ;
  285. $values += $v ;
  286. ++ $count ;
  287.     }
  288.     ok 66, $count == 3 ;
  289.     ok 67, $keys == 1011 ;
  290.     ok 68, $values == 2022 ;
  292.     # now clear the hash
  293.     %hash = () ;
  294.     ok 69, keys %hash == 0 ;
  296.     untie %hash ;
  297. }
  299. {
  300.     # override default compare
  301.     my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
  302.     my $value ;
  303.     my (%h, %g, %k) ;
  304.     my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ; 
  305.     ok 70, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 
  306.      -Compare   => sub { $_[0] <=> $_[1] },
  307.      -Flags    => DB_CREATE ;
  309.     ok 71, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 
  310.      -Compare   => sub { $_[0] cmp $_[1] },
  311.      -Flags    => DB_CREATE ;
  313.     ok 72, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, 
  314.    -Compare   => sub { length $_[0] <=> length $_[1] },
  315.    -Flags    => DB_CREATE ;
  317.     my @srt_1 ;
  318.     { local $^W = 0 ;
  319.       @srt_1 = sort { $a <=> $b } @Keys ; 
  320.     }
  321.     my @srt_2 = sort { $a cmp $b } @Keys ;
  322.     my @srt_3 = sort { length $a <=> length $b } @Keys ;
  324.     foreach (@Keys) {
  325.         local $^W = 0 ;
  326.         $h{$_} = 1 ; 
  327.         $g{$_} = 1 ;
  328.         $k{$_} = 1 ;
  329.     }
  331.     sub ArrayCompare
  332.     {
  333.         my($a, $b) = @_ ;
  334.     
  335.         return 0 if @$a != @$b ;
  336.     
  337.         foreach (1 .. length @$a)
  338.         {
  339.             return 0 unless $$a[$_] eq $$b[$_] ;
  340.         }
  342.         1 ;
  343.     }
  345.     ok 73, ArrayCompare (@srt_1, [keys %h]);
  346.     ok 74, ArrayCompare (@srt_2, [keys %g]);
  347.     ok 75, ArrayCompare (@srt_3, [keys %k]);
  349. }
  351. {
  352.     # override default compare, with duplicates, don't sort values
  353.     my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
  354.     my $value ;
  355.     my (%h, %g, %k) ;
  356.     my @Keys   = qw( 0123 9 12 -1234 9 987654321 def  ) ; 
  357.     my @Values = qw( 1    0 3   dd   x abc       0    ) ; 
  358.     ok 76, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 
  359.      -Compare   => sub { $_[0] <=> $_[1] },
  360.      -Property  => DB_DUP,
  361.      -Flags    => DB_CREATE ;
  363.     ok 77, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 
  364.      -Compare   => sub { $_[0] cmp $_[1] },
  365.      -Property  => DB_DUP,
  366.      -Flags    => DB_CREATE ;
  368.     ok 78, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, 
  369.    -Compare   => sub { length $_[0] <=> length $_[1] },
  370.    -Property  => DB_DUP,
  371.    -Flags    => DB_CREATE ;
  373.     my @srt_1 ;
  374.     { local $^W = 0 ;
  375.       @srt_1 = sort { $a <=> $b } @Keys ; 
  376.     }
  377.     my @srt_2 = sort { $a cmp $b } @Keys ;
  378.     my @srt_3 = sort { length $a <=> length $b } @Keys ;
  380.     foreach (@Keys) {
  381.         local $^W = 0 ;
  382. my $value = shift @Values ;
  383.         $h{$_} = $value ; 
  384.         $g{$_} = $value ;
  385.         $k{$_} = $value ;
  386.     }
  388.     sub getValues
  389.     {
  390.          my $hash = shift ;
  391.  my $db = tied %$hash ;
  392.  my $cursor = $db->db_cursor() ;
  393.  my @values = () ;
  394.  my ($k, $v) = (0,0) ;
  395.          while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  396.      push @values, $v ;
  397.  }
  398.  return @values ;
  399.     }
  401.     ok 79, ArrayCompare (@srt_1, [keys %h]);
  402.     ok 80, ArrayCompare (@srt_2, [keys %g]);
  403.     ok 81, ArrayCompare (@srt_3, [keys %k]);
  404.     ok 82, ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues %h]);
  405.     ok 83, ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues %g]);
  406.     ok 84, ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues %k]);
  408.     # test DB_DUP_NEXT
  409.     ok 85, my $cur = (tied %g)->db_cursor() ;
  410.     my ($k, $v) = (9, "") ;
  411.     ok 86, $cur->c_get($k, $v, DB_SET) == 0 ;
  412.     ok 87, $k == 9 && $v == 0 ;
  413.     ok 88, $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
  414.     ok 89, $k == 9 && $v eq "x" ;
  415.     ok 90, $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
  416. }
  418. {
  419.     # override default compare, with duplicates, sort values
  420.     my $lex = new LexFile $Dfile, $Dfile2;
  421.     my $value ;
  422.     my (%h, %g) ;
  423.     my @Keys   = qw( 0123 9 12 -1234 9 987654321 9 def  ) ; 
  424.     my @Values = qw( 1    11 3   dd   x abc      2 0    ) ; 
  425.     ok 91, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, 
  426.      -Compare   => sub { $_[0] <=> $_[1] },
  427.      -DupCompare   => sub { $_[0] cmp $_[1] },
  428.      -Property  => DB_DUP,
  429.      -Flags    => DB_CREATE ;
  431.     ok 92, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, 
  432.      -Compare   => sub { $_[0] cmp $_[1] },
  433.      -DupCompare   => sub { $_[0] <=> $_[1] },
  434.      -Property  => DB_DUP,
  435.      
  436.      
  437.      
  438.      -Flags    => DB_CREATE ;
  440.     my @srt_1 ;
  441.     { local $^W = 0 ;
  442.       @srt_1 = sort { $a <=> $b } @Keys ; 
  443.     }
  444.     my @srt_2 = sort { $a cmp $b } @Keys ;
  446.     foreach (@Keys) {
  447.         local $^W = 0 ;
  448. my $value = shift @Values ;
  449.         $h{$_} = $value ; 
  450.         $g{$_} = $value ;
  451.     }
  453.     ok 93, ArrayCompare (@srt_1, [keys %h]);
  454.     ok 94, ArrayCompare (@srt_2, [keys %g]);
  455.     ok 95, ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues %g]);
  456.     ok 96, ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues %h]);
  458. }
  460. {
  461.     # get_dup etc
  462.     my $lex = new LexFile $Dfile;
  463.     my %hh ;
  465.     ok 97, my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile, 
  466.      -DupCompare   => sub { $_[0] cmp $_[1] },
  467.      -Property  => DB_DUP,
  468.      -Flags    => DB_CREATE ;
  470.     $hh{'Wall'} = 'Larry' ;
  471.     $hh{'Wall'} = 'Stone' ; # Note the duplicate key
  472.     $hh{'Wall'} = 'Brick' ; # Note the duplicate key
  473.     $hh{'Smith'} = 'John' ;
  474.     $hh{'mouse'} = 'mickey' ;
  475.     
  476.     # first work in scalar context
  477.     ok 98, scalar $YY->get_dup('Unknown') == 0 ;
  478.     ok 99, scalar $YY->get_dup('Smith') == 1 ;
  479.     ok 100, scalar $YY->get_dup('Wall') == 3 ;
  480.     
  481.     # now in list context
  482.     my @unknown = $YY->get_dup('Unknown') ;
  483.     ok 101, "@unknown" eq "" ;
  484.     
  485.     my @smith = $YY->get_dup('Smith') ;
  486.     ok 102, "@smith" eq "John" ;
  487.     
  488.     {
  489.     my @wall = $YY->get_dup('Wall') ;
  490.     my %wall ;
  491.     @wall{@wall} = @wall ;
  492.     ok 103, (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
  493.     }
  494.     
  495.     # hash
  496.     my %unknown = $YY->get_dup('Unknown', 1) ;
  497.     ok 104, keys %unknown == 0 ;
  498.     
  499.     my %smith = $YY->get_dup('Smith', 1) ;
  500.     ok 105, keys %smith == 1 && $smith{'John'} ;
  501.     
  502.     my %wall = $YY->get_dup('Wall', 1) ;
  503.     ok 106, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
  504.      && $wall{'Brick'} == 1 ;
  505.     
  506.     undef $YY ;
  507.     untie %hh ;
  509. }
  511. {
  512.     # in-memory file
  514.     my $lex = new LexFile $Dfile ;
  515.     my %hash ;
  516.     my $fd ;
  517.     my $value ;
  518.     ok 107, my $db = tie %hash, 'BerkeleyDB::Btree' ;
  520.     ok 108, $db->db_put("some key", "some value") == 0  ;
  521.     ok 109, $db->db_get("some key", $value) == 0 ;
  522.     ok 110, $value eq "some value" ;
  524. }
  525.  
  526. {
  527.     # partial
  528.     # check works via API
  530.     my $lex = new LexFile $Dfile ;
  531.     my $value ;
  532.     ok 111, my $db = new BerkeleyDB::Btree, -Filename => $Dfile,
  533.                                               -Flags    => DB_CREATE ;
  535.     # create some data
  536.     my %data =  (
  537. "red" => "boat",
  538. "green" => "house",
  539. "blue" => "sea",
  540. ) ;
  542.     my $ret = 0 ;
  543.     while (my ($k, $v) = each %data) {
  544.         $ret += $db->db_put($k, $v) ;
  545.     }
  546.     ok 112, $ret == 0 ;
  549.     # do a partial get
  550.     my ($pon, $off, $len) = $db->partial_set(0,2) ;
  551.     ok 113, ! $pon && $off == 0 && $len == 0 ;
  552.     ok 114, $db->db_get("red", $value) == 0 && $value eq "bo" ;
  553.     ok 115, $db->db_get("green", $value) == 0 && $value eq "ho" ;
  554.     ok 116, $db->db_get("blue", $value) == 0 && $value eq "se" ;
  556.     # do a partial get, off end of data
  557.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  558.     ok 117, $pon ;
  559.     ok 118, $off == 0 ;
  560.     ok 119, $len == 2 ;
  561.     ok 120, $db->db_get("red", $value) == 0 && $value eq "t" ;
  562.     ok 121, $db->db_get("green", $value) == 0 && $value eq "se" ;
  563.     ok 122, $db->db_get("blue", $value) == 0 && $value eq "" ;
  565.     # switch of partial mode
  566.     ($pon, $off, $len) = $db->partial_clear() ;
  567.     ok 123, $pon ;
  568.     ok 124, $off == 3 ;
  569.     ok 125, $len == 2 ;
  570.     ok 126, $db->db_get("red", $value) == 0 && $value eq "boat" ;
  571.     ok 127, $db->db_get("green", $value) == 0 && $value eq "house" ;
  572.     ok 128, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
  574.     # now partial put
  575.     $db->partial_set(0,2) ;
  576.     ok 129, $db->db_put("red", "") == 0 ;
  577.     ok 130, $db->db_put("green", "AB") == 0 ;
  578.     ok 131, $db->db_put("blue", "XYZ") == 0 ;
  579.     ok 132, $db->db_put("new", "KLM") == 0 ;
  581.     ($pon, $off, $len) = $db->partial_clear() ;
  582.     ok 133, $pon ;
  583.     ok 134, $off == 0 ;
  584.     ok 135, $len == 2 ;
  585.     ok 136, $db->db_get("red", $value) == 0 && $value eq "at" ;
  586.     ok 137, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
  587.     ok 138, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
  588.     ok 139, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
  590.     # now partial put
  591.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  592.     ok 140, ! $pon ;
  593.     ok 141, $off == 0 ;
  594.     ok 142, $len == 0 ;
  595.     ok 143, $db->db_put("red", "PPP") == 0 ;
  596.     ok 144, $db->db_put("green", "Q") == 0 ;
  597.     ok 145, $db->db_put("blue", "XYZ") == 0 ;
  598.     ok 146, $db->db_put("new", "TU") == 0 ;
  600.     $db->partial_clear() ;
  601.     ok 147, $db->db_get("red", $value) == 0 && $value eq "atPPP" ;
  602.     ok 148, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
  603.     ok 149, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
  604.     ok 150, $db->db_get("new", $value) == 0 && $value eq "KLMTU" ;
  605. }
  607. {
  608.     # partial
  609.     # check works via tied hash 
  611.     my $lex = new LexFile $Dfile ;
  612.     my %hash ;
  613.     my $value ;
  614.     ok 151, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
  615.                                               -Flags    => DB_CREATE ;
  617.     # create some data
  618.     my %data =  (
  619. "red" => "boat",
  620. "green" => "house",
  621. "blue" => "sea",
  622. ) ;
  624.     while (my ($k, $v) = each %data) {
  625. $hash{$k} = $v ;
  626.     }
  629.     # do a partial get
  630.     $db->partial_set(0,2) ;
  631.     ok 152, $hash{"red"} eq "bo" ;
  632.     ok 153, $hash{"green"} eq "ho" ;
  633.     ok 154, $hash{"blue"}  eq "se" ;
  635.     # do a partial get, off end of data
  636.     $db->partial_set(3,2) ;
  637.     ok 155, $hash{"red"} eq "t" ;
  638.     ok 156, $hash{"green"} eq "se" ;
  639.     ok 157, $hash{"blue"} eq "" ;
  641.     # switch of partial mode
  642.     $db->partial_clear() ;
  643.     ok 158, $hash{"red"} eq "boat" ;
  644.     ok 159, $hash{"green"} eq "house" ;
  645.     ok 160, $hash{"blue"} eq "sea" ;
  647.     # now partial put
  648.     $db->partial_set(0,2) ;
  649.     ok 161, $hash{"red"} = "" ;
  650.     ok 162, $hash{"green"} = "AB" ;
  651.     ok 163, $hash{"blue"} = "XYZ" ;
  652.     ok 164, $hash{"new"} = "KLM" ;
  654.     $db->partial_clear() ;
  655.     ok 165, $hash{"red"} eq "at" ;
  656.     ok 166, $hash{"green"} eq "ABuse" ;
  657.     ok 167, $hash{"blue"} eq "XYZa" ;
  658.     ok 168, $hash{"new"} eq "KLM" ;
  660.     # now partial put
  661.     $db->partial_set(3,2) ;
  662.     ok 169, $hash{"red"} = "PPP" ;
  663.     ok 170, $hash{"green"} = "Q" ;
  664.     ok 171, $hash{"blue"} = "XYZ" ;
  665.     ok 172, $hash{"new"} = "TU" ;
  667.     $db->partial_clear() ;
  668.     ok 173, $hash{"red"} eq "atPPP" ;
  669.     ok 174, $hash{"green"} eq "ABuQ" ;
  670.     ok 175, $hash{"blue"} eq "XYZXYZ" ;
  671.     ok 176, $hash{"new"} eq "KLMTU" ;
  672. }
  674. {
  675.     # transaction
  677.     my $lex = new LexFile $Dfile ;
  678.     my %hash ;
  679.     my $value ;
  681.     my $home = "./fred" ;
  682.     rmtree $home if -e $home ;
  683.     ok 177, mkdir($home, 0777) ;
  684.     ok 178, my $env = new BerkeleyDB::Env -Home => $home,
  685.      -Flags => DB_CREATE|DB_INIT_TXN|
  686.    DB_INIT_MPOOL|DB_INIT_LOCK ;
  687.     ok 179, my $txn = $env->txn_begin() ;
  688.     ok 180, my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
  689.                                               -Flags    =>  DB_CREATE ,
  690.        -Env   => $env,
  691.        -Txn  => $txn ;
  693.     
  694.     # create some data
  695.     my %data =  (
  696. "red" => "boat",
  697. "green" => "house",
  698. "blue" => "sea",
  699. ) ;
  701.     my $ret = 0 ;
  702.     while (my ($k, $v) = each %data) {
  703.         $ret += $db1->db_put($k, $v) ;
  704.     }
  705.     ok 181, $ret == 0 ;
  707.     # should be able to see all the records
  709.     ok 182, my $cursor = $db1->db_cursor() ;
  710.     my ($k, $v) = ("", "") ;
  711.     my $count = 0 ;
  712.     # sequence forwards
  713.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  714.         ++ $count ;
  715.     }
  716.     ok 183, $count == 3 ;
  717.     undef $cursor ;
  719.     # now abort the transaction
  720.     #ok 151, $txn->txn_abort() == 0 ;
  721.     ok 184, (my $Z = $txn->txn_abort()) == 0 ;
  723.     # there shouldn't be any records in the database
  724.     $count = 0 ;
  725.     # sequence forwards
  726.     ok 185, $cursor = $db1->db_cursor() ;
  727.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  728.         ++ $count ;
  729.     }
  730.     ok 186, $count == 0 ;
  732.     undef $txn ;
  733.     undef $cursor ;
  734.     undef $db1 ;
  735.     undef $env ;
  736.     untie %hash ;
  737.     rmtree $home ;
  738. }
  740. {
  741.     # DB_DUP
  743.     my $lex = new LexFile $Dfile ;
  744.     my %hash ;
  745.     ok 187, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
  746.       -Property  => DB_DUP,
  747.                                       -Flags    => DB_CREATE ;
  749.     $hash{'Wall'} = 'Larry' ;
  750.     $hash{'Wall'} = 'Stone' ;
  751.     $hash{'Smith'} = 'John' ;
  752.     $hash{'Wall'} = 'Brick' ;
  753.     $hash{'Wall'} = 'Brick' ;
  754.     $hash{'mouse'} = 'mickey' ;
  756.     ok 188, keys %hash == 6 ;
  758.     # create a cursor
  759.     ok 189, my $cursor = $db->db_cursor() ;
  761.     my $key = "Wall" ;
  762.     my $value ;
  763.     ok 190, $cursor->c_get($key, $value, DB_SET) == 0 ;
  764.     ok 191, $key eq "Wall" && $value eq "Larry" ;
  765.     ok 192, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  766.     ok 193, $key eq "Wall" && $value eq "Stone" ;
  767.     ok 194, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  768.     ok 195, $key eq "Wall" && $value eq "Brick" ;
  769.     ok 196, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  770.     ok 197, $key eq "Wall" && $value eq "Brick" ;
  772.     my $ref = $db->db_stat() ; 
  773.     ok 198, ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
  775.     undef $db ;
  776.     undef $cursor ;
  777.     untie %hash ;
  779. }
  781. {
  782.     # db_stat
  784.     my $lex = new LexFile $Dfile ;
  785.     my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
  786.     my %hash ;
  787.     my ($k, $v) ;
  788.     ok 199, my $db = new BerkeleyDB::Btree -Filename => $Dfile, 
  789.      -Flags    => DB_CREATE,
  790.   -Minkey =>3 ,
  791. -Pagesize => 2 **12 
  792. ;
  794.     my $ref = $db->db_stat() ; 
  795.     ok 200, $ref->{$recs} == 0;
  796.     ok 201, $ref->{'bt_minkey'} == 3;
  797.     ok 202, $ref->{'bt_pagesize'} == 2 ** 12;
  799.     # create some data
  800.     my %data =  (
  801. "red" => 2,
  802. "green" => "house",
  803. "blue" => "sea",
  804. ) ;
  806.     my $ret = 0 ;
  807.     while (($k, $v) = each %data) {
  808.         $ret += $db->db_put($k, $v) ;
  809.     }
  810.     ok 203, $ret == 0 ;
  812.     $ref = $db->db_stat() ; 
  813.     ok 204, $ref->{$recs} == 3;
  814. }
  816. {
  817.    # sub-class test
  819.    package Another ;
  821.    use strict ;
  823.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  824.    print FILE <<'EOM' ;
  826.    package SubDB ;
  828.    use strict ;
  829.    use vars qw( @ISA @EXPORT) ;
  831.    require Exporter ;
  832.    use BerkeleyDB;
  833.    @ISA=qw(BerkeleyDB::Btree);
  834.    @EXPORT = @BerkeleyDB::EXPORT ;
  836.    sub db_put { 
  837. my $self = shift ;
  838.         my $key = shift ;
  839.         my $value = shift ;
  840.         $self->SUPER::db_put($key, $value * 3) ;
  841.    }
  843.    sub db_get { 
  844. my $self = shift ;
  845.         $self->SUPER::db_get($_[0], $_[1]) ;
  846. $_[1] -= 2 ;
  847.    }
  849.    sub A_new_method
  850.    {
  851. my $self = shift ;
  852.         my $key = shift ;
  853.         my $value = $self->FETCH($key) ;
  854. return "[[$value]]" ;
  855.    }
  857.    1 ;
  858. EOM
  860.     close FILE ;
  862.     BEGIN { push @INC, '.'; }    
  863.     eval 'use SubDB ; ';
  864.     main::ok 205, $@ eq "" ;
  865.     my %h ;
  866.     my $X ;
  867.     eval '
  868. $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp", 
  869. -Flags => DB_CREATE,
  870. -Mode => 0640 );
  871. ' ;
  873.     main::ok 206, $@ eq "" ;
  875.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  876.     main::ok 207, $@ eq "" ;
  877.     main::ok 208, $ret == 7 ;
  879.     my $value = 0;
  880.     $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
  881.     main::ok 209, $@ eq "" ;
  882.     main::ok 210, $ret == 10 ;
  884.     $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
  885.     main::ok 211, $@ eq ""  ;
  886.     main::ok 212, $ret == 1 ;
  888.     $ret = eval '$X->A_new_method("joe") ' ;
  889.     main::ok 213, $@ eq "" ;
  890.     main::ok 214, $ret eq "[[10]]" ;
  892.     unlink "SubDB.pm", "dbbtree.tmp" ;
  894. }
  896. {
  897.     # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO
  899.     my $lex = new LexFile $Dfile ;
  900.     my %hash ;
  901.     my ($k, $v) = ("", "");
  902.     ok 215, my $db = new BerkeleyDB::Btree 
  903. -Filename  => $Dfile, 
  904.       -Flags     => DB_CREATE,
  905.       -Property  => DB_RECNUM ;
  908.     # create some data
  909.     my @data =  (
  910. "A zero",
  911. "B one",
  912. "C two",
  913. "D three",
  914. "E four"
  915. ) ;
  917.     my $ix = 0 ;
  918.     my $ret = 0 ;
  919.     foreach (@data) {
  920.         $ret += $db->db_put($_, $ix) ;
  921. ++ $ix ;
  922.     }
  923.     ok 216, $ret == 0 ;
  925.     # db_get & DB_SET_RECNO
  926.     $k = 1 ;
  927.     ok 217, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  928.     ok 218, $k eq "B one" && $v == 1 ;
  930.     $k = 3 ;
  931.     ok 219, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  932.     ok 220, $k eq "D three" && $v == 3 ;
  934.     $k = 4 ;
  935.     ok 221, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  936.     ok 222, $k eq "E four" && $v == 4 ;
  938.     $k = 0 ;
  939.     ok 223, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  940.     ok 224, $k eq "A zero" && $v == 0 ;
  942.     # cursor & DB_SET_RECNO
  944.     # create the cursor
  945.     ok 225, my $cursor = $db->db_cursor() ;
  947.     $k = 2 ;
  948.     ok 226, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  949.     ok 227, $k eq "C two" && $v == 2 ;
  951.     $k = 0 ;
  952.     ok 228, $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
  953.     ok 229, $k eq "A zero" && $v == 0 ;
  955.     $k = 3 ;
  956.     ok 230, $db->db_get($k, $v, DB_SET_RECNO) == 0;
  957.     ok 231, $k eq "D three" && $v == 3 ;
  959.     # cursor & DB_GET_RECNO
  960.     ok 232, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
  961.     ok 233, $k eq "A zero" && $v == 0 ;
  962.     ok 234, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
  963.     ok 235, $v == 0 ;
  965.     ok 236, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  966.     ok 237, $k eq "B one" && $v == 1 ;
  967.     ok 238, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
  968.     ok 239, $v == 1 ;
  970.     ok 240, $cursor->c_get($k, $v, DB_LAST) == 0 ;
  971.     ok 241, $k eq "E four" && $v == 4 ;
  972.     ok 242, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
  973.     ok 243, $v == 4 ;
  975. }