开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 数据库系统 > MySQL数据库 > 查看源码
hash.t
资源名称：mysql-3.23.35.tar.gz　[点击查看]
上传用户：tsgydb
上传日期：2007-04-14
资源大小：10674k
文件大小：20k
源码类别：

MySQL数据库

开发平台：

Visual C++

hash.t：源码内容
  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..210n";
  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. }
  59. sub ok
  60. {
  61.     my $no = shift ;
  62.     my $result = shift ;
  63.  
  64.     print "not " unless $result ;
  65.     print "ok $non" ;
  66. }
  68. my $Dfile = "dbhash.tmp";
  69. my $Dfile2 = "dbhash2.tmp";
  70. my $Dfile3 = "dbhash3.tmp";
  71. unlink $Dfile;
  73. umask(0) ;
  76. # Check for invalid parameters
  77. {
  78.     # Check for invalid parameters
  79.     my $db ;
  80.     eval ' $db = new BerkeleyDB::Hash  -Stupid => 3 ; ' ;
  81.     ok 1, $@ =~ /unknown key value(s) Stupid/  ;
  83.     eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
  84.     ok 2, $@ =~ /unknown key value(s) (Bad |Stupid ){2}/  ;
  86.     eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ;
  87.     ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  89.     eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ;
  90.     ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
  92.     my $obj = bless [], "main" ;
  93.     eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ;
  94.     ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  95. }
  97. # Now check the interface to HASH
  99. {
  100.     my $lex = new LexFile $Dfile ;
  102.     ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
  103.     -Flags    => DB_CREATE ;
  105.     # Add a k/v pair
  106.     my $value ;
  107.     my $status ;
  108.     ok 7, $db->db_put("some key", "some value") == 0  ;
  109.     ok 8, $db->status() == 0 ;
  110.     ok 9, $db->db_get("some key", $value) == 0 ;
  111.     ok 10, $value eq "some value" ;
  112.     ok 11, $db->db_put("key", "value") == 0  ;
  113.     ok 12, $db->db_get("key", $value) == 0 ;
  114.     ok 13, $value eq "value" ;
  115.     ok 14, $db->db_del("some key") == 0 ;
  116.     ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
  117.     ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ;
  118.     ok 17, $db->status() == DB_NOTFOUND ;
  119.     ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'};
  121.     ok 19, $db->db_sync() == 0 ;
  123.     # Check NOOVERWRITE will make put fail when attempting to overwrite
  124.     # an existing record.
  126.     ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
  127.     ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'};
  128.     ok 22, $db->status() == DB_KEYEXIST ;
  130.     # check that the value of the key  has not been changed by the
  131.     # previous test
  132.     ok 23, $db->db_get("key", $value) == 0 ;
  133.     ok 24, $value eq "value" ;
  135.     # test DB_GET_BOTH
  136.     my ($k, $v) = ("key", "value") ;
  137.     ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
  139.     ($k, $v) = ("key", "fred") ;
  140.     ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  142.     ($k, $v) = ("another", "value") ;
  143.     ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  146. }
  148. {
  149.     # Check simple env works with a hash.
  150.     my $lex = new LexFile $Dfile ;
  152.     my $home = "./fred" ;
  153.     ok 28, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;
  155.     ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL,
  156.       -Home  => $home ;
  157.     ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
  158.     -Env      => $env,
  159.     -Flags    => DB_CREATE ;
  161.     # Add a k/v pair
  162.     my $value ;
  163.     ok 31, $db->db_put("some key", "some value") == 0 ;
  164.     ok 32, $db->db_get("some key", $value) == 0 ;
  165.     ok 33, $value eq "some value" ;
  166.     undef $db ;
  167.     undef $env ;
  168.     rmtree $home ;
  169. }
  171. {
  172.     # override default hash
  173.     my $lex = new LexFile $Dfile ;
  174.     my $value ;
  175.     $::count = 0 ;
  176.     ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
  177.      -Hash     => sub {  ++$::count ; length $_[0] },
  178.      -Flags    => DB_CREATE ;
  180.     ok 35, $db->db_put("some key", "some value") == 0 ;
  181.     ok 36, $db->db_get("some key", $value) == 0 ;
  182.     ok 37, $value eq "some value" ;
  183.     ok 38, $::count > 0 ;
  185. }
  186.  
  187. {
  188.     # cursors
  190.     my $lex = new LexFile $Dfile ;
  191.     my %hash ;
  192.     my ($k, $v) ;
  193.     ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
  194.      -Flags    => DB_CREATE ;
  196.     # create some data
  197.     my %data =  (
  198. "red" => 2,
  199. "green" => "house",
  200. "blue" => "sea",
  201. ) ;
  203.     my $ret = 0 ;
  204.     while (($k, $v) = each %data) {
  205.         $ret += $db->db_put($k, $v) ;
  206.     }
  207.     ok 40, $ret == 0 ;
  209.     # create the cursor
  210.     ok 41, my $cursor = $db->db_cursor() ;
  212.     $k = $v = "" ;
  213.     my %copy = %data ;
  214.     my $extras = 0 ;
  215.     # sequence forwards
  216.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  217.         if ( $copy{$k} eq $v ) 
  218.             { delete $copy{$k} }
  219. else
  220.     { ++ $extras }
  221.     }
  222.     ok 42, $cursor->status() == DB_NOTFOUND ;
  223.     ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
  224.     ok 44, keys %copy == 0 ;
  225.     ok 45, $extras == 0 ;
  227.     # sequence backwards
  228.     %copy = %data ;
  229.     $extras = 0 ;
  230.     my $status ;
  231.     for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
  232.   $status == 0 ;
  233.        $status = $cursor->c_get($k, $v, DB_PREV)) {
  234.         if ( $copy{$k} eq $v ) 
  235.             { delete $copy{$k} }
  236. else
  237.     { ++ $extras }
  238.     }
  239.     ok 46, $status == DB_NOTFOUND ;
  240.     ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ;
  241.     ok 48, $cursor->status() == $status ;
  242.     ok 49, $cursor->status() eq $status ;
  243.     ok 50, keys %copy == 0 ;
  244.     ok 51, $extras == 0 ;
  246.     ($k, $v) = ("green", "house") ;
  247.     ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
  249.     ($k, $v) = ("green", "door") ;
  250.     ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  252.     ($k, $v) = ("black", "house") ;
  253.     ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
  254.     
  255. }
  256.  
  257. {
  258.     # Tied Hash interface
  260.     my $lex = new LexFile $Dfile ;
  261.     my %hash ;
  262.     ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
  263.                                       -Flags    => DB_CREATE ;
  265.     # check "each" with an empty database
  266.     my $count = 0 ;
  267.     while (my ($k, $v) = each %hash) {
  268. ++ $count ;
  269.     }
  270.     ok 56, (tied %hash)->status() == DB_NOTFOUND ;
  271.     ok 57, $count == 0 ;
  273.     # Add a k/v pair
  274.     my $value ;
  275.     $hash{"some key"} = "some value";
  276.     ok 58, (tied %hash)->status() == 0 ;
  277.     ok 59, $hash{"some key"} eq "some value";
  278.     ok 60, defined $hash{"some key"} ;
  279.     ok 61, (tied %hash)->status() == 0 ;
  280.     ok 62, exists $hash{"some key"} ;
  281.     ok 63, !defined $hash{"jimmy"} ;
  282.     ok 64, (tied %hash)->status() == DB_NOTFOUND ;
  283.     ok 65, !exists $hash{"jimmy"} ;
  284.     ok 66, (tied %hash)->status() == DB_NOTFOUND ;
  286.     delete $hash{"some key"} ;
  287.     ok 67, (tied %hash)->status() == 0 ;
  288.     ok 68, ! defined $hash{"some key"} ;
  289.     ok 69, (tied %hash)->status() == DB_NOTFOUND ;
  290.     ok 70, ! exists $hash{"some key"} ;
  291.     ok 71, (tied %hash)->status() == DB_NOTFOUND ;
  293.     $hash{1} = 2 ;
  294.     $hash{10} = 20 ;
  295.     $hash{1000} = 2000 ;
  297.     my ($keys, $values) = (0,0);
  298.     $count = 0 ;
  299.     while (my ($k, $v) = each %hash) {
  300.         $keys += $k ;
  301. $values += $v ;
  302. ++ $count ;
  303.     }
  304.     ok 72, $count == 3 ;
  305.     ok 73, $keys == 1011 ;
  306.     ok 74, $values == 2022 ;
  308.     # now clear the hash
  309.     %hash = () ;
  310.     ok 75, keys %hash == 0 ;
  312.     untie %hash ;
  313. }
  315. {
  316.     # in-memory file
  318.     my $lex = new LexFile $Dfile ;
  319.     my %hash ;
  320.     my $fd ;
  321.     my $value ;
  322.     ok 76, my $db = tie %hash, 'BerkeleyDB::Hash' ;
  324.     ok 77, $db->db_put("some key", "some value") == 0  ;
  325.     ok 78, $db->db_get("some key", $value) == 0 ;
  326.     ok 79, $value eq "some value" ;
  328.     undef $db ;
  329.     untie %hash ;
  330. }
  331.  
  332. {
  333.     # partial
  334.     # check works via API
  336.     my $lex = new LexFile $Dfile ;
  337.     my %hash ;
  338.     my $value ;
  339.     ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
  340.                                               -Flags    => DB_CREATE ;
  342.     # create some data
  343.     my %data =  (
  344. "red" => "boat",
  345. "green" => "house",
  346. "blue" => "sea",
  347. ) ;
  349.     my $ret = 0 ;
  350.     while (my ($k, $v) = each %data) {
  351.         $ret += $db->db_put($k, $v) ;
  352.     }
  353.     ok 81, $ret == 0 ;
  356.     # do a partial get
  357.     my($pon, $off, $len) = $db->partial_set(0,2) ;
  358.     ok 82, $pon == 0 && $off == 0 && $len == 0 ;
  359.     ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ;
  360.     ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ;
  361.     ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ;
  363.     # do a partial get, off end of data
  364.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  365.     ok 86, $pon ;
  366.     ok 87, $off == 0 ;
  367.     ok 88, $len == 2 ;
  368.     ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ;
  369.     ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ;
  370.     ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ;
  372.     # switch of partial mode
  373.     ($pon, $off, $len) = $db->partial_clear() ;
  374.     ok 92, $pon ;
  375.     ok 93, $off == 3 ;
  376.     ok 94, $len == 2 ;
  377.     ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ;
  378.     ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ;
  379.     ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
  381.     # now partial put
  382.     ($pon, $off, $len) = $db->partial_set(0,2) ;
  383.     ok 98, ! $pon ;
  384.     ok 99, $off == 0 ;
  385.     ok 100, $len == 0 ;
  386.     ok 101, $db->db_put("red", "") == 0 ;
  387.     ok 102, $db->db_put("green", "AB") == 0 ;
  388.     ok 103, $db->db_put("blue", "XYZ") == 0 ;
  389.     ok 104, $db->db_put("new", "KLM") == 0 ;
  391.     $db->partial_clear() ;
  392.     ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ;
  393.     ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
  394.     ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
  395.     ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
  397.     # now partial put
  398.     $db->partial_set(3,2) ;
  399.     ok 109, $db->db_put("red", "PPP") == 0 ;
  400.     ok 110, $db->db_put("green", "Q") == 0 ;
  401.     ok 111, $db->db_put("blue", "XYZ") == 0 ;
  402.     ok 112, $db->db_put("new", "--") == 0 ;
  404.     ($pon, $off, $len) = $db->partial_clear() ;
  405.     ok 113, $pon ;
  406.     ok 114, $off == 3 ;
  407.     ok 115, $len == 2 ;
  408.     ok 116, $db->db_get("red", $value) == 0 && $value eq "atPPP" ;
  409.     ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
  410.     ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
  411.     ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
  412. }
  414. {
  415.     # partial
  416.     # check works via tied hash 
  418.     my $lex = new LexFile $Dfile ;
  419.     my %hash ;
  420.     my $value ;
  421.     ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
  422.                                               -Flags    => DB_CREATE ;
  424.     # create some data
  425.     my %data =  (
  426. "red" => "boat",
  427. "green" => "house",
  428. "blue" => "sea",
  429. ) ;
  431.     while (my ($k, $v) = each %data) {
  432. $hash{$k} = $v ;
  433.     }
  436.     # do a partial get
  437.     $db->partial_set(0,2) ;
  438.     ok 121, $hash{"red"} eq "bo" ;
  439.     ok 122, $hash{"green"} eq "ho" ;
  440.     ok 123, $hash{"blue"}  eq "se" ;
  442.     # do a partial get, off end of data
  443.     $db->partial_set(3,2) ;
  444.     ok 124, $hash{"red"} eq "t" ;
  445.     ok 125, $hash{"green"} eq "se" ;
  446.     ok 126, $hash{"blue"} eq "" ;
  448.     # switch of partial mode
  449.     $db->partial_clear() ;
  450.     ok 127, $hash{"red"} eq "boat" ;
  451.     ok 128, $hash{"green"} eq "house" ;
  452.     ok 129, $hash{"blue"} eq "sea" ;
  454.     # now partial put
  455.     $db->partial_set(0,2) ;
  456.     ok 130, $hash{"red"} = "" ;
  457.     ok 131, $hash{"green"} = "AB" ;
  458.     ok 132, $hash{"blue"} = "XYZ" ;
  459.     ok 133, $hash{"new"} = "KLM" ;
  461.     $db->partial_clear() ;
  462.     ok 134, $hash{"red"} eq "at" ;
  463.     ok 135, $hash{"green"} eq "ABuse" ;
  464.     ok 136, $hash{"blue"} eq "XYZa" ;
  465.     ok 137, $hash{"new"} eq "KLM" ;
  467.     # now partial put
  468.     $db->partial_set(3,2) ;
  469.     ok 138, $hash{"red"} = "PPP" ;
  470.     ok 139, $hash{"green"} = "Q" ;
  471.     ok 140, $hash{"blue"} = "XYZ" ;
  472.     ok 141, $hash{"new"} = "TU" ;
  474.     $db->partial_clear() ;
  475.     ok 142, $hash{"red"} eq "atPPP" ;
  476.     ok 143, $hash{"green"} eq "ABuQ" ;
  477.     ok 144, $hash{"blue"} eq "XYZXYZ" ;
  478.     ok 145, $hash{"new"} eq "KLMTU" ;
  479. }
  481. {
  482.     # transaction
  484.     my $lex = new LexFile $Dfile ;
  485.     my %hash ;
  486.     my $value ;
  488.     my $home = "./fred" ;
  489.     rmtree $home if -e $home ;
  490.     ok 146, mkdir($home, 0777) ;
  491.     ok 147, my $env = new BerkeleyDB::Env -Home => $home,
  492.      -Flags => DB_CREATE|DB_INIT_TXN|
  493.    DB_INIT_MPOOL|DB_INIT_LOCK ;
  494.     ok 148, my $txn = $env->txn_begin() ;
  495.     ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
  496.                                                -Flags     => DB_CREATE ,
  497.         -Env     => $env,
  498.      -Txn    => $txn  ;
  500.     
  501.     # create some data
  502.     my %data =  (
  503. "red" => "boat",
  504. "green" => "house",
  505. "blue" => "sea",
  506. ) ;
  508.     my $ret = 0 ;
  509.     while (my ($k, $v) = each %data) {
  510.         $ret += $db1->db_put($k, $v) ;
  511.     }
  512.     ok 150, $ret == 0 ;
  514.     # should be able to see all the records
  516.     ok 151, my $cursor = $db1->db_cursor() ;
  517.     my ($k, $v) = ("", "") ;
  518.     my $count = 0 ;
  519.     # sequence forwards
  520.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  521.         ++ $count ;
  522.     }
  523.     ok 152, $count == 3 ;
  524.     undef $cursor ;
  526.     # now abort the transaction
  527.     ok 153, $txn->txn_abort() == 0 ;
  529.     # there shouldn't be any records in the database
  530.     $count = 0 ;
  531.     # sequence forwards
  532.     ok 154, $cursor = $db1->db_cursor() ;
  533.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  534.         ++ $count ;
  535.     }
  536.     ok 155, $count == 0 ;
  538.     undef $txn ;
  539.     undef $cursor ;
  540.     undef $db1 ;
  541.     undef $env ;
  542.     untie %hash ;
  543.     rmtree $home ;
  544. }
  547. {
  548.     # DB_DUP
  550.     my $lex = new LexFile $Dfile ;
  551.     my %hash ;
  552.     ok 156, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
  553.       -Property  => DB_DUP,
  554.                                       -Flags    => DB_CREATE ;
  556.     $hash{'Wall'} = 'Larry' ;
  557.     $hash{'Wall'} = 'Stone' ;
  558.     $hash{'Smith'} = 'John' ;
  559.     $hash{'Wall'} = 'Brick' ;
  560.     $hash{'Wall'} = 'Brick' ;
  561.     $hash{'mouse'} = 'mickey' ;
  563.     ok 157, keys %hash == 6 ;
  565.     # create a cursor
  566.     ok 158, my $cursor = $db->db_cursor() ;
  568.     my $key = "Wall" ;
  569.     my $value ;
  570.     ok 159, $cursor->c_get($key, $value, DB_SET) == 0 ;
  571.     ok 160, $key eq "Wall" && $value eq "Larry" ;
  572.     ok 161, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  573.     ok 162, $key eq "Wall" && $value eq "Stone" ;
  574.     ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  575.     ok 164, $key eq "Wall" && $value eq "Brick" ;
  576.     ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  577.     ok 166, $key eq "Wall" && $value eq "Brick" ;
  579.     #my $ref = $db->db_stat() ; 
  580.     #ok 143, $ref->{bt_flags} | DB_DUP ;
  582.     # test DB_DUP_NEXT
  583.     my ($k, $v) = ("Wall", "") ;
  584.     ok 167, $cursor->c_get($k, $v, DB_SET) == 0 ;
  585.     ok 168, $k eq "Wall" && $v eq "Larry" ;
  586.     ok 169, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
  587.     ok 170, $k eq "Wall" && $v eq "Stone" ;
  588.     ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
  589.     ok 172, $k eq "Wall" && $v eq "Brick" ;
  590.     ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
  591.     ok 174, $k eq "Wall" && $v eq "Brick" ;
  592.     ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
  593.     
  595.     undef $db ;
  596.     undef $cursor ;
  597.     untie %hash ;
  599. }
  601. {
  602.     # DB_DUP & DupCompare
  603.     my $lex = new LexFile $Dfile, $Dfile2;
  604.     my ($key, $value) ;
  605.     my (%h, %g) ;
  606.     my @Keys   = qw( 0123 9 12 -1234 9 987654321 9 def  ) ; 
  607.     my @Values = qw( 1    11 3   dd   x abc      2 0    ) ; 
  609.     ok 176, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile, 
  610.      -DupCompare   => sub { $_[0] cmp $_[1] },
  611.      -Property  => DB_DUP|DB_DUPSORT,
  612.      -Flags    => DB_CREATE ;
  614.     ok 177, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2, 
  615.      -DupCompare   => sub { $_[0] <=> $_[1] },
  616.      -Property  => DB_DUP|DB_DUPSORT,
  617.      -Flags    => DB_CREATE ;
  619.     foreach (@Keys) {
  620.         local $^W = 0 ;
  621. my $value = shift @Values ;
  622.         $h{$_} = $value ; 
  623.         $g{$_} = $value ;
  624.     }
  626.     ok 178, my $cursor = (tied %h)->db_cursor() ;
  627.     $key = 9 ; $value = "";
  628.     ok 179, $cursor->c_get($key, $value, DB_SET) == 0 ;
  629.     ok 180, $key == 9 && $value eq 11 ;
  630.     ok 181, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  631.     ok 182, $key == 9 && $value == 2 ;
  632.     ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  633.     ok 184, $key == 9 && $value eq "x" ;
  635.     $cursor = (tied %g)->db_cursor() ;
  636.     $key = 9 ;
  637.     ok 185, $cursor->c_get($key, $value, DB_SET) == 0 ;
  638.     ok 186, $key == 9 && $value eq "x" ;
  639.     ok 187, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  640.     ok 188, $key == 9 && $value == 2 ;
  641.     ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
  642.     ok 190, $key == 9 && $value  == 11 ;
  645. }
  647. {
  648.     # get_dup etc
  649.     my $lex = new LexFile $Dfile;
  650.     my %hh ;
  652.     ok 191, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile, 
  653.      -DupCompare   => sub { $_[0] cmp $_[1] },
  654.      -Property  => DB_DUP,
  655.      -Flags    => DB_CREATE ;
  657.     $hh{'Wall'} = 'Larry' ;
  658.     $hh{'Wall'} = 'Stone' ; # Note the duplicate key
  659.     $hh{'Wall'} = 'Brick' ; # Note the duplicate key
  660.     $hh{'Smith'} = 'John' ;
  661.     $hh{'mouse'} = 'mickey' ;
  662.     
  663.     # first work in scalar context
  664.     ok 192, scalar $YY->get_dup('Unknown') == 0 ;
  665.     ok 193, scalar $YY->get_dup('Smith') == 1 ;
  666.     ok 194, scalar $YY->get_dup('Wall') == 3 ;
  667.     
  668.     # now in list context
  669.     my @unknown = $YY->get_dup('Unknown') ;
  670.     ok 195, "@unknown" eq "" ;
  671.     
  672.     my @smith = $YY->get_dup('Smith') ;
  673.     ok 196, "@smith" eq "John" ;
  674.     
  675.     {
  676.         my @wall = $YY->get_dup('Wall') ;
  677.         my %wall ;
  678.         @wall{@wall} = @wall ;
  679.         ok 197, (@wall == 3 && $wall{'Larry'} 
  680. && $wall{'Stone'} && $wall{'Brick'});
  681.     }
  682.     
  683.     # hash
  684.     my %unknown = $YY->get_dup('Unknown', 1) ;
  685.     ok 198, keys %unknown == 0 ;
  686.     
  687.     my %smith = $YY->get_dup('Smith', 1) ;
  688.     ok 199, keys %smith == 1 && $smith{'John'} ;
  689.     
  690.     my %wall = $YY->get_dup('Wall', 1) ;
  691.     ok 200, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
  692.      && $wall{'Brick'} == 1 ;
  693.     
  694.     undef $YY ;
  695.     untie %hh ;
  697. }
  699. {
  700.    # sub-class test
  702.    package Another ;
  704.    use strict ;
  706.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  707.    print FILE <<'EOM' ;
  709.    package SubDB ;
  711.    use strict ;
  712.    use vars qw( @ISA @EXPORT) ;
  714.    require Exporter ;
  715.    use BerkeleyDB;
  716.    @ISA=qw(BerkeleyDB::Hash);
  717.    @EXPORT = @BerkeleyDB::EXPORT ;
  719.    sub db_put { 
  720. my $self = shift ;
  721.         my $key = shift ;
  722.         my $value = shift ;
  723.         $self->SUPER::db_put($key, $value * 3) ;
  724.    }
  726.    sub db_get { 
  727. my $self = shift ;
  728.         $self->SUPER::db_get($_[0], $_[1]) ;
  729. $_[1] -= 2 ;
  730.    }
  732.    sub A_new_method
  733.    {
  734. my $self = shift ;
  735.         my $key = shift ;
  736.         my $value = $self->FETCH($key) ;
  737. return "[[$value]]" ;
  738.    }
  740.    1 ;
  741. EOM
  743.     close FILE ;
  745.     BEGIN { push @INC, '.'; }    
  746.     eval 'use SubDB ; ';
  747.     main::ok 201, $@ eq "" ;
  748.     my %h ;
  749.     my $X ;
  750.     eval '
  751. $X = tie(%h, "SubDB", -Filename => "dbhash.tmp", 
  752. -Flags => DB_CREATE,
  753. -Mode => 0640 );
  754. ' ;
  756.     main::ok 202, $@ eq "" ;
  758.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  759.     main::ok 203, $@ eq "" ;
  760.     main::ok 204, $ret == 7 ;
  762.     my $value = 0;
  763.     $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
  764.     main::ok 205, $@ eq "" ;
  765.     main::ok 206, $ret == 10 ;
  767.     $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
  768.     main::ok 207, $@ eq ""  ;
  769.     main::ok 208, $ret == 1 ;
  771.     $ret = eval '$X->A_new_method("joe") ' ;
  772.     main::ok 209, $@ eq "" ;
  773.     main::ok 210, $ret eq "[[10]]" ;
  775.     unlink "SubDB.pm", "dbhash.tmp" ;
  777. }