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

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

MySQL数据库

开发平台：

Visual C++

recno.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 BerkeleyDB; 
  15. use File::Path qw(rmtree);
  17. print "1..218n";
  19. my %DB_errors = (
  20.     'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
  21.     'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
  22.     'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
  23.     'DB_LOCK_DEADLOCK'  => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
  24.     'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
  25.     'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
  26.     'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade",
  27.     'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery",
  28. ) ;
  30. {
  31.     package LexFile ;
  33.     sub new
  34.     {
  35. my $self = shift ;
  36. unlink @_ ;
  37.   bless [ @_ ], $self ;
  38.     }
  40.     sub DESTROY
  41.     {
  42. my $self = shift ;
  43. unlink @{ $self } ;
  44.     }
  45. }
  48. sub ok
  49. {
  50.     my $no = shift ;
  51.     my $result = shift ;
  52.  
  53.     print "not " unless $result ;
  54.     print "ok $non" ;
  55. }
  57. sub docat
  58. {
  59.     my $file = shift;
  60.     local $/ = undef;
  61.     open(CAT,$file) || die "Cannot open $file:$!";
  62.     my $result = <CAT>;
  63.     close(CAT);
  64.     return $result;
  65. }
  67. sub touch
  68. {
  69.     my $file = shift ;
  70.     open(CAT,">$file") || die "Cannot open $file:$!";
  71.     close(CAT);
  72. }
  74. sub joiner
  75. {
  76.     my $db = shift ;
  77.     my $sep = shift ;
  78.     my ($k, $v) = (0, "") ;
  79.     my @data = () ;
  81.     my $cursor = $db->db_cursor()  or return () ;
  82.     for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
  83.           $status == 0 ;
  84.           $status = $cursor->c_get($k, $v, DB_NEXT)) {
  85. push @data, $v ;
  86.     }
  88.     (scalar(@data), join($sep, @data)) ;
  89. }
  91. sub countRecords
  92. {
  93.    my $db = shift ;
  94.    my ($k, $v) = (0,0) ;
  95.    my ($count) = 0 ;
  96.    my ($cursor) = $db->db_cursor() ;
  97.    #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
  98. # $status == 0 ;
  99. # $status = $cursor->c_get($k, $v, DB_NEXT) )
  100.    while ($cursor->c_get($k, $v, DB_NEXT) == 0)
  101.      { ++ $count }
  103.    return $count ;
  104. }
  106. my $Dfile = "dbhash.tmp";
  107. my $Dfile2 = "dbhash2.tmp";
  108. my $Dfile3 = "dbhash3.tmp";
  109. unlink $Dfile;
  111. umask(0) ;
  114. # Check for invalid parameters
  115. {
  116.     # Check for invalid parameters
  117.     my $db ;
  118.     eval ' $db = new BerkeleyDB::Recno  -Stupid => 3 ; ' ;
  119.     ok 1, $@ =~ /unknown key value(s) Stupid/  ;
  121.     eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
  122.     ok 2, $@ =~ /unknown key value(s) /  ;
  124.     eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ;
  125.     ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  127.     eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ;
  128.     ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
  130.     my $obj = bless [], "main" ;
  131.     eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ;
  132.     ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  133. }
  135. # Now check the interface to Recno
  137. {
  138.     my $lex = new LexFile $Dfile ;
  140.     ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile, 
  141.     -Flags    => DB_CREATE ;
  143.     # Add a k/v pair
  144.     my $value ;
  145.     my $status ;
  146.     ok 7, $db->db_put(1, "some value") == 0  ;
  147.     ok 8, $db->status() == 0 ;
  148.     ok 9, $db->db_get(1, $value) == 0 ;
  149.     ok 10, $value eq "some value" ;
  150.     ok 11, $db->db_put(2, "value") == 0  ;
  151.     ok 12, $db->db_get(2, $value) == 0 ;
  152.     ok 13, $value eq "value" ;
  153.     ok 14, $db->db_del(1) == 0 ;
  154.     ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
  155.     ok 16, $db->status() == DB_KEYEMPTY ;
  156.     ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
  158.     ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
  159.     ok 19, $db->status() == DB_NOTFOUND ;
  160.     ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
  162.     ok 21, $db->db_sync() == 0 ;
  164.     # Check NOOVERWRITE will make put fail when attempting to overwrite
  165.     # an existing record.
  167.     ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
  168.     ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
  169.     ok 24, $db->status() == DB_KEYEXIST ;
  172.     # check that the value of the key  has not been changed by the
  173.     # previous test
  174.     ok 25, $db->db_get(2, $value) == 0 ;
  175.     ok 26, $value eq "value" ;
  178. }
  181. {
  182.     # Check simple env works with a array.
  183.     my $lex = new LexFile $Dfile ;
  185.     my $home = "./fred" ;
  186.     ok 27, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;
  188.     ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
  189.       -Home => $home ;
  191.     ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile, 
  192.     -Env      => $env,
  193.     -Flags    => DB_CREATE ;
  195.     # Add a k/v pair
  196.     my $value ;
  197.     ok 30, $db->db_put(1, "some value") == 0 ;
  198.     ok 31, $db->db_get(1, $value) == 0 ;
  199.     ok 32, $value eq "some value" ;
  200.     undef $db ;
  201.     undef $env ;
  202.     rmtree $home ;
  203. }
  205.  
  206. {
  207.     # cursors
  209.     my $lex = new LexFile $Dfile ;
  210.     my @array ;
  211.     my ($k, $v) ;
  212.     ok 33, my $db = new BerkeleyDB::Recno -Filename  => $Dfile, 
  213.        -ArrayBase => 0,
  214.        -Flags     => DB_CREATE ;
  216.     # create some data
  217.     my @data =  (
  218. "red" ,
  219. "green" ,
  220. "blue" ,
  221. ) ;
  223.     my $i ;
  224.     my %data ;
  225.     my $ret = 0 ;
  226.     for ($i = 0 ; $i < @data ; ++$i) {
  227.         $ret += $db->db_put($i, $data[$i]) ;
  228. $data{$i} = $data[$i] ;
  229.     }
  230.     ok 34, $ret == 0 ;
  232.     # create the cursor
  233.     ok 35, my $cursor = $db->db_cursor() ;
  235.     $k = 0 ; $v = "" ;
  236.     my %copy = %data;
  237.     my $extras = 0 ;
  238.     # sequence forwards
  239.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) 
  240.     {
  241.         if ( $copy{$k} eq $v ) 
  242.             { delete $copy{$k} }
  243. else
  244.     { ++ $extras }
  245.     }
  247.     ok 36, $cursor->status() == DB_NOTFOUND ;
  248.     ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
  249.     ok 38, keys %copy == 0 ;
  250.     ok 39, $extras == 0 ;
  252.     # sequence backwards
  253.     %copy = %data ;
  254.     $extras = 0 ;
  255.     my $status ;
  256.     for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
  257.   $status == 0 ;
  258.        $status = $cursor->c_get($k, $v, DB_PREV)) {
  259.         if ( $copy{$k} eq $v ) 
  260.             { delete $copy{$k} }
  261. else
  262.     { ++ $extras }
  263.     }
  264.     ok 40, $status == DB_NOTFOUND ;
  265.     ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
  266.     ok 42, $cursor->status() == $status ;
  267.     ok 43, $cursor->status() eq $status ;
  268.     ok 44, keys %copy == 0 ;
  269.     ok 45, $extras == 0 ;
  270. }
  271.  
  272. {
  273.     # Tied Array interface
  275.     # full tied array support started in Perl 5.004_57
  276.     # just double check.
  277.     my $FA = 0 ;
  278.     {
  279.         sub try::TIEARRAY { bless [], "try" }
  280.         sub try::FETCHSIZE { $FA = 1 }
  281.         my @a ; 
  282.         tie @a, 'try' ;
  283.         my $a = @a ;
  284.     }
  286.     my $lex = new LexFile $Dfile ;
  287.     my @array ;
  288.     my $db ;
  289.     ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  290.          -Property => DB_RENUMBER,
  291.          -ArrayBase => 0,
  292.                                             -Flags     => DB_CREATE ;
  294.     ok 47, my $cursor = (tied @array)->db_cursor() ;
  295.     # check the database is empty
  296.     my $count = 0 ;
  297.     my ($k, $v) = (0,"") ;
  298.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  299. ++ $count ;
  300.     }
  301.     ok 48, $cursor->status() == DB_NOTFOUND ;
  302.     ok 49, $count == 0 ;
  304.     ok 50, @array == 0 ;
  306.     # Add a k/v pair
  307.     my $value ;
  308.     $array[1] = "some value";
  309.     ok 51, (tied @array)->status() == 0 ;
  310.     ok 52, $array[1] eq "some value";
  311.     ok 53, defined $array[1];
  312.     ok 54, (tied @array)->status() == 0 ;
  313.     ok 55, !defined $array[3];
  314.     ok 56, (tied @array)->status() == DB_NOTFOUND ;
  316.     ok 57, (tied @array)->db_del(1) == 0 ;
  317.     ok 58, (tied @array)->status() == 0 ;
  318.     ok 59, ! defined $array[1];
  319.     ok 60, (tied @array)->status() == DB_NOTFOUND ;
  321.     $array[1] = 2 ;
  322.     $array[10] = 20 ;
  323.     $array[1000] = 2000 ;
  325.     my ($keys, $values) = (0,0);
  326.     $count = 0 ;
  327.     for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
  328.   $status == 0 ;
  329.        $status = $cursor->c_get($k, $v, DB_NEXT)) {
  330.         $keys += $k ;
  331. $values += $v ;
  332. ++ $count ;
  333.     }
  334.     ok 61, $count == 3 ;
  335.     ok 62, $keys == 1011 ;
  336.     ok 63, $values == 2022 ;
  338.     # unshift
  339.     $FA ? unshift @array, "red", "green", "blue" 
  340.         : $db->unshift("red", "green", "blue" ) ;
  341.     ok 64, $array[1] eq "red" ;
  342.     ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
  343.     ok 66, $k == 1 ;
  344.     ok 67, $v eq "red" ;
  345.     ok 68, $array[2] eq "green" ;
  346.     ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  347.     ok 70, $k == 2 ;
  348.     ok 71, $v eq "green" ;
  349.     ok 72, $array[3] eq "blue" ;
  350.     ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  351.     ok 74, $k == 3 ;
  352.     ok 75, $v eq "blue" ;
  353.     ok 76, $array[4] == 2 ;
  354.     ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  355.     ok 78, $k == 4 ;
  356.     ok 79, $v == 2 ;
  358.     # shift
  359.     ok 80, ($FA ? shift @array : $db->shift()) eq "red" ;
  360.     ok 81, ($FA ? shift @array : $db->shift()) eq "green" ;
  361.     ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ;
  362.     ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
  364.     # push
  365.     $FA ? push @array, "the", "end" 
  366.         : $db->push("the", "end") ;
  367.     ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
  368.     ok 85, $k == 1001 ;
  369.     ok 86, $v eq "end" ;
  370.     ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
  371.     ok 88, $k == 1000 ;
  372.     ok 89, $v eq "the" ;
  373.     ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
  374.     ok 91, $k == 999 ;
  375.     ok 92, $v == 2000 ;
  377.     # pop
  378.     ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ;
  379.     ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ;
  380.     ok 95, ( $FA ? pop @array : $db->pop ) == 2000  ;
  382.     # now clear the array 
  383.     $FA ? @array = () 
  384.         : $db->clear() ;
  385.     ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
  387.     undef $cursor ;
  388.     undef $db ;
  389.     untie @array ;
  390. }
  392. {
  393.     # in-memory file
  395.     my @array ;
  396.     my $fd ;
  397.     my $value ;
  398.     ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ;
  400.     ok 98, $db->db_put(1, "some value") == 0  ;
  401.     ok 99, $db->db_get(1, $value) == 0 ;
  402.     ok 100, $value eq "some value" ;
  404. }
  405.  
  406. {
  407.     # partial
  408.     # check works via API
  410.     my $lex = new LexFile $Dfile ;
  411.     my $value ;
  412.     ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile,
  413.                                                -Flags    => DB_CREATE ;
  415.     # create some data
  416.     my @data =  (
  417. "",
  418. "boat",
  419. "house",
  420. "sea",
  421. ) ;
  423.     my $ret = 0 ;
  424.     my $i ;
  425.     for ($i = 1 ; $i < @data ; ++$i) {
  426.         $ret += $db->db_put($i, $data[$i]) ;
  427.     }
  428.     ok 102, $ret == 0 ;
  431.     # do a partial get
  432.     my ($pon, $off, $len) = $db->partial_set(0,2) ;
  433.     ok 103, ! $pon && $off == 0 && $len == 0 ;
  434.     ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
  435.     ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
  436.     ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
  438.     # do a partial get, off end of data
  439.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  440.     ok 107, $pon ;
  441.     ok 108, $off == 0 ;
  442.     ok 109, $len == 2 ;
  443.     ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ;
  444.     ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
  445.     ok 112, $db->db_get(3, $value) == 0 && $value eq "" ;
  447.     # switch of partial mode
  448.     ($pon, $off, $len) = $db->partial_clear() ;
  449.     ok 113, $pon ;
  450.     ok 114, $off == 3 ;
  451.     ok 115, $len == 2 ;
  452.     ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ;
  453.     ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ;
  454.     ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ;
  456.     # now partial put
  457.     $db->partial_set(0,2) ;
  458.     ok 119, $db->db_put(1, "") == 0 ;
  459.     ok 120, $db->db_put(2, "AB") == 0 ;
  460.     ok 121, $db->db_put(3, "XYZ") == 0 ;
  461.     ok 122, $db->db_put(4, "KLM") == 0 ;
  463.     ($pon, $off, $len) = $db->partial_clear() ;
  464.     ok 123, $pon ;
  465.     ok 124, $off == 0 ;
  466.     ok 125, $len == 2 ;
  467.     ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ;
  468.     ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
  469.     ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
  470.     ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ;
  472.     # now partial put
  473.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  474.     ok 130, ! $pon ;
  475.     ok 131, $off == 0 ;
  476.     ok 132, $len == 0 ;
  477.     ok 133, $db->db_put(1, "PPP") == 0 ;
  478.     ok 134, $db->db_put(2, "Q") == 0 ;
  479.     ok 135, $db->db_put(3, "XYZ") == 0 ;
  480.     ok 136, $db->db_put(4, "TU") == 0 ;
  482.     $db->partial_clear() ;
  483.     ok 137, $db->db_get(1, $value) == 0 && $value eq "atPPP" ;
  484.     ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
  485.     ok 139, $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
  486.     ok 140, $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
  487. }
  489. {
  490.     # partial
  491.     # check works via tied array 
  493.     my $lex = new LexFile $Dfile ;
  494.     my @array ;
  495.     my $value ;
  496.     ok 141, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
  497.                                                -Flags    => DB_CREATE ;
  499.     # create some data
  500.     my @data =  (
  501. "",
  502. "boat",
  503. "house",
  504. "sea",
  505. ) ;
  507.     my $i ;
  508.     for ($i = 1 ; $i < @data ; ++$i) {
  509. $array[$i] = $data[$i] ;
  510.     }
  513.     # do a partial get
  514.     $db->partial_set(0,2) ;
  515.     ok 142, $array[1] eq "bo" ;
  516.     ok 143, $array[2] eq "ho" ;
  517.     ok 144, $array[3]  eq "se" ;
  519.     # do a partial get, off end of data
  520.     $db->partial_set(3,2) ;
  521.     ok 145, $array[1] eq "t" ;
  522.     ok 146, $array[2] eq "se" ;
  523.     ok 147, $array[3] eq "" ;
  525.     # switch of partial mode
  526.     $db->partial_clear() ;
  527.     ok 148, $array[1] eq "boat" ;
  528.     ok 149, $array[2] eq "house" ;
  529.     ok 150, $array[3] eq "sea" ;
  531.     # now partial put
  532.     $db->partial_set(0,2) ;
  533.     ok 151, $array[1] = "" ;
  534.     ok 152, $array[2] = "AB" ;
  535.     ok 153, $array[3] = "XYZ" ;
  536.     ok 154, $array[4] = "KLM" ;
  538.     $db->partial_clear() ;
  539.     ok 155, $array[1] eq "at" ;
  540.     ok 156, $array[2] eq "ABuse" ;
  541.     ok 157, $array[3] eq "XYZa" ;
  542.     ok 158, $array[4] eq "KLM" ;
  544.     # now partial put
  545.     $db->partial_set(3,2) ;
  546.     ok 159, $array[1] = "PPP" ;
  547.     ok 160, $array[2] = "Q" ;
  548.     ok 161, $array[3] = "XYZ" ;
  549.     ok 162, $array[4] = "TU" ;
  551.     $db->partial_clear() ;
  552.     ok 163, $array[1] eq "atPPP" ;
  553.     ok 164, $array[2] eq "ABuQ" ;
  554.     ok 165, $array[3] eq "XYZXYZ" ;
  555.     ok 166, $array[4] eq "KLMTU" ;
  556. }
  558. {
  559.     # transaction
  561.     my $lex = new LexFile $Dfile ;
  562.     my @array ;
  563.     my $value ;
  565.     my $home = "./fred" ;
  566.     rmtree $home if -e $home ;
  567.     ok 167, mkdir($home, 0777) ;
  568.     ok 168, my $env = new BerkeleyDB::Env -Home => $home,
  569.      -Flags => DB_CREATE|DB_INIT_TXN|
  570.    DB_INIT_MPOOL|DB_INIT_LOCK ;
  571.     ok 169, my $txn = $env->txn_begin() ;
  572.     ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno', 
  573. -Filename => $Dfile,
  574. -ArrayBase => 0,
  575.                        -Flags    =>  DB_CREATE ,
  576.          -Env    => $env,
  577.          -Txn   => $txn ;
  579.     
  580.     # create some data
  581.     my @data =  (
  582. "boat",
  583. "house",
  584. "sea",
  585. ) ;
  587.     my $ret = 0 ;
  588.     my $i ;
  589.     for ($i = 0 ; $i < @data ; ++$i) {
  590.         $ret += $db1->db_put($i, $data[$i]) ;
  591.     }
  592.     ok 171, $ret == 0 ;
  594.     # should be able to see all the records
  596.     ok 172, my $cursor = $db1->db_cursor() ;
  597.     my ($k, $v) = (0, "") ;
  598.     my $count = 0 ;
  599.     # sequence forwards
  600.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  601.         ++ $count ;
  602.     }
  603.     ok 173, $count == 3 ;
  604.     undef $cursor ;
  606.     # now abort the transaction
  607.     ok 174, $txn->txn_abort() == 0 ;
  609.     # there shouldn't be any records in the database
  610.     $count = 0 ;
  611.     # sequence forwards
  612.     ok 175, $cursor = $db1->db_cursor() ;
  613.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  614.         ++ $count ;
  615.     }
  616.     ok 176, $count == 0 ;
  618.     undef $txn ;
  619.     undef $cursor ;
  620.     undef $db1 ;
  621.     undef $env ;
  622.     untie @array ;
  623.     rmtree $home ;
  624. }
  627. {
  628.     # db_stat
  630.     my $lex = new LexFile $Dfile ;
  631.     my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
  632.     my @array ;
  633.     my ($k, $v) ;
  634.     ok 177, my $db = new BerkeleyDB::Recno -Filename  => $Dfile, 
  635.          -Flags     => DB_CREATE,
  636.    -Pagesize => 4 * 1024,
  637. ;
  639.     my $ref = $db->db_stat() ; 
  640.     ok 178, $ref->{$recs} == 0;
  641.     ok 179, $ref->{'bt_pagesize'} == 4 * 1024;
  643.     # create some data
  644.     my @data =  (
  645. 2,
  646. "house",
  647. "sea",
  648. ) ;
  650.     my $ret = 0 ;
  651.     my $i ;
  652.     for ($i = $db->ArrayOffset ; @data ; ++$i) {
  653.         $ret += $db->db_put($i, shift @data) ;
  654.     }
  655.     ok 180, $ret == 0 ;
  657.     $ref = $db->db_stat() ; 
  658.     ok 181, $ref->{$recs} == 3;
  659. }
  661. {
  662.    # sub-class test
  664.    package Another ;
  666.    use strict ;
  668.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  669.    print FILE <<'EOM' ;
  671.    package SubDB ;
  673.    use strict ;
  674.    use vars qw( @ISA @EXPORT) ;
  676.    require Exporter ;
  677.    use BerkeleyDB;
  678.    @ISA=qw(BerkeleyDB::Recno);
  679.    @EXPORT = @BerkeleyDB::EXPORT ;
  681.    sub db_put { 
  682. my $self = shift ;
  683.         my $key = shift ;
  684.         my $value = shift ;
  685.         $self->SUPER::db_put($key, $value * 3) ;
  686.    }
  688.    sub db_get { 
  689. my $self = shift ;
  690.         $self->SUPER::db_get($_[0], $_[1]) ;
  691. $_[1] -= 2 ;
  692.    }
  694.    sub A_new_method
  695.    {
  696. my $self = shift ;
  697.         my $key = shift ;
  698.         my $value = $self->FETCH($key) ;
  699. return "[[$value]]" ;
  700.    }
  702.    1 ;
  703. EOM
  705.     close FILE ;
  707.     BEGIN { push @INC, '.'; }    
  708.     eval 'use SubDB ; ';
  709.     main::ok 182, $@ eq "" ;
  710.     my @h ;
  711.     my $X ;
  712.     eval '
  713. $X = tie(@h, "SubDB", -Filename => "dbbtree.tmp", 
  714. -Flags => DB_CREATE,
  715. -Mode => 0640 );
  716. ' ;
  718.     main::ok 183, $@ eq "" ;
  720.     my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
  721.     main::ok 184, $@ eq "" ;
  722.     main::ok 185, $ret == 7 ;
  724.     my $value = 0;
  725.     $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
  726.     main::ok 186, $@ eq "" ;
  727.     main::ok 187, $ret == 10 ;
  729.     $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
  730.     main::ok 188, $@ eq ""  ;
  731.     main::ok 189, $ret == 1 ;
  733.     $ret = eval '$X->A_new_method(1) ' ;
  734.     main::ok 190, $@ eq "" ;
  735.     main::ok 191, $ret eq "[[10]]" ;
  737.     unlink "SubDB.pm", "dbbtree.tmp" ;
  739. }
  741. {
  742.     # variable length records, DB_DELIMETER -- defaults to n
  744.     my $lex = new LexFile $Dfile, $Dfile2 ;
  745.     touch $Dfile2 ;
  746.     my @array ;
  747.     my $value ;
  748.     ok 192, tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  749. -ArrayBase => 0,
  750.                                                -Flags  => DB_CREATE ,
  751. -Source => $Dfile2 ;
  752.     $array[0] = "abc" ;
  753.     $array[1] = "def" ;
  754.     $array[3] = "ghi" ;
  755.     untie @array ;
  757.     my $x = docat($Dfile2) ;
  758.     ok 193, $x eq "abcndefnnghin" ;
  759. }
  761. {
  762.     # variable length records, change DB_DELIMETER
  764.     my $lex = new LexFile $Dfile, $Dfile2 ;
  765.     touch $Dfile2 ;
  766.     my @array ;
  767.     my $value ;
  768.     ok 194, tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  769. -ArrayBase => 0,
  770.                                                -Flags  => DB_CREATE ,
  771. -Source => $Dfile2 ,
  772. -Delim => "-";
  773.     $array[0] = "abc" ;
  774.     $array[1] = "def" ;
  775.     $array[3] = "ghi" ;
  776.     untie @array ;
  778.     my $x = docat($Dfile2) ;
  779.     ok 195, $x eq "abc-def--ghi-";
  780. }
  782. {
  783.     # fixed length records, default DB_PAD
  785.     my $lex = new LexFile $Dfile, $Dfile2 ;
  786.     touch $Dfile2 ;
  787.     my @array ;
  788.     my $value ;
  789.     ok 196, tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  790. -ArrayBase => 0,
  791.                                                -Flags  => DB_CREATE ,
  792. -Len  => 5,
  793. -Source => $Dfile2 ;
  794.     $array[0] = "abc" ;
  795.     $array[1] = "def" ;
  796.     $array[3] = "ghi" ;
  797.     untie @array ;
  799.     my $x = docat($Dfile2) ;
  800.     ok 197, $x eq "abc  def       ghi  " ;
  801. }
  803. {
  804.     # fixed length records, change Pad
  806.     my $lex = new LexFile $Dfile, $Dfile2 ;
  807.     touch $Dfile2 ;
  808.     my @array ;
  809.     my $value ;
  810.     ok 198, tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  811. -ArrayBase => 0,
  812.                                                -Flags  => DB_CREATE ,
  813. -Len => 5,
  814. -Pad => "-",
  815. -Source => $Dfile2 ;
  816.     $array[0] = "abc" ;
  817.     $array[1] = "def" ;
  818.     $array[3] = "ghi" ;
  819.     untie @array ;
  821.     my $x = docat($Dfile2) ;
  822.     ok 199, $x eq "abc--def-------ghi--" ;
  823. }
  825. {
  826.     # DB_RENUMBER
  828.     my $lex = new LexFile $Dfile;
  829.     my @array ;
  830.     my $value ;
  831.     ok 200, my $db = tie @array, 'BerkeleyDB::Recno', -Filename  => $Dfile,
  832.           -Property => DB_RENUMBER,
  833. -ArrayBase => 0,
  834.                                                -Flags  => DB_CREATE ;
  835.     # create a few records
  836.     $array[0] = "abc" ;
  837.     $array[1] = "def" ;
  838.     $array[3] = "ghi" ;
  840.     ok 201, my ($length, $joined) = joiner($db, "|") ;
  841.     ok 202, $length == 3 ;
  842.     ok 203, $joined eq "abc|def|ghi";
  844.     ok 204, $db->db_del(1) == 0 ;
  845.     ok 205, ($length, $joined) = joiner($db, "|") ;
  846.     ok 206, $length == 2 ;
  847.     ok 207, $joined eq "abc|ghi";
  849.     undef $db ;
  850.     untie @array ;
  852. }
  854. {
  855.     # DB_APPEND
  857.     my $lex = new LexFile $Dfile;
  858.     my @array ;
  859.     my $value ;
  860.     ok 208, my $db = tie @array, 'BerkeleyDB::Recno', 
  861. -Filename  => $Dfile,
  862.                                         -Flags     => DB_CREATE ;
  864.     # create a few records
  865.     $array[1] = "def" ;
  866.     $array[3] = "ghi" ;
  868.     my $k = 0 ;
  869.     ok 209, $db->db_put($k, "fred", DB_APPEND) == 0 ;
  870.     ok 210, $k == 4 ;
  872.     undef $db ;
  873.     untie @array ;
  874. }
  876. {
  877.     # in-memory Btree with an associated text file
  879.     my $lex = new LexFile $Dfile2 ;
  880.     touch $Dfile2 ;
  881.     my @array ;
  882.     my $value ;
  883.     ok 211, tie @array, 'BerkeleyDB::Recno',    -Source => $Dfile2 ,
  884. -ArrayBase => 0,
  885.           -Property => DB_RENUMBER,
  886.                                                -Flags  => DB_CREATE ;
  887.     $array[0] = "abc" ;
  888.     $array[1] = "def" ;
  889.     $array[3] = "ghi" ;
  890.     untie @array ;
  892.     my $x = docat($Dfile2) ;
  893.     ok 212, $x eq "abcndefnnghin" ;
  894. }
  896. {
  897.     # in-memory, variable length records, change DB_DELIMETER
  899.     my $lex = new LexFile $Dfile, $Dfile2 ;
  900.     touch $Dfile2 ;
  901.     my @array ;
  902.     my $value ;
  903.     ok 213, tie @array, 'BerkeleyDB::Recno', 
  904. -ArrayBase => 0,
  905.                                                -Flags  => DB_CREATE ,
  906. -Source => $Dfile2 ,
  907.           -Property => DB_RENUMBER,
  908. -Delim => "-";
  909.     $array[0] = "abc" ;
  910.     $array[1] = "def" ;
  911.     $array[3] = "ghi" ;
  912.     untie @array ;
  914.     my $x = docat($Dfile2) ;
  915.     ok 214, $x eq "abc-def--ghi-";
  916. }
  918. {
  919.     # in-memory, fixed length records, default DB_PAD
  921.     my $lex = new LexFile $Dfile, $Dfile2 ;
  922.     touch $Dfile2 ;
  923.     my @array ;
  924.     my $value ;
  925.     ok 215, tie @array, 'BerkeleyDB::Recno',  -ArrayBase => 0,
  926.                                                -Flags  => DB_CREATE ,
  927.           -Property => DB_RENUMBER,
  928. -Len  => 5,
  929. -Source => $Dfile2 ;
  930.     $array[0] = "abc" ;
  931.     $array[1] = "def" ;
  932.     $array[3] = "ghi" ;
  933.     untie @array ;
  935.     my $x = docat($Dfile2) ;
  936.     ok 216, $x eq "abc  def       ghi  " ;
  937. }
  939. {
  940.     # in-memory, fixed length records, change Pad
  942.     my $lex = new LexFile $Dfile, $Dfile2 ;
  943.     touch $Dfile2 ;
  944.     my @array ;
  945.     my $value ;
  946.     ok 217, tie @array, 'BerkeleyDB::Recno', 
  947. -ArrayBase => 0,
  948.                                                -Flags  => DB_CREATE ,
  949.           -Property => DB_RENUMBER,
  950. -Len => 5,
  951. -Pad => "-",
  952. -Source => $Dfile2 ;
  953.     $array[0] = "abc" ;
  954.     $array[1] = "def" ;
  955.     $array[3] = "ghi" ;
  956.     untie @array ;
  958.     my $x = docat($Dfile2) ;
  959.     ok 218, $x eq "abc--def-------ghi--" ;
  960. }
  962. __END__
  965. # TODO
  966. #
  967. # DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records