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

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

MySQL数据库

开发平台：

Visual C++

queue.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. BEGIN 
  18. {
  19.     if ($BerkeleyDB::db_version < 3) {
  20. print "1..0 # Skipping test, Queue needs Berkeley DB 3.x or bettern" ;
  21. exit 0 ;
  22.     }
  23. }    
  25. print "1..197n";
  27. my %DB_errors = (
  28. 'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
  29. 'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
  30. 'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
  31. 'DB_LOCK_DEADLOCK' => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
  32. 'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
  33. 'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
  34. 'DB_OLD_VERSION'=> "DB_OLDVERSION: Database requires a version upgrade",
  35. 'DB_RUNRECOVERY'=> "DB_RUNRECOVERY: Fatal error, run database recovery",
  36. ) ;
  38. {
  39.     package LexFile ;
  41.     sub new
  42.     {
  43. my $self = shift ;
  44. unlink @_ ;
  45.   bless [ @_ ], $self ;
  46.     }
  48.     sub DESTROY
  49.     {
  50. my $self = shift ;
  51. unlink @{ $self } ;
  52.     }
  53. }
  56. sub ok
  57. {
  58.     my $no = shift ;
  59.     my $result = shift ;
  60.  
  61.     print "not " unless $result ;
  62.     print "ok $non" ;
  63. }
  65. sub docat
  66. {
  67.     my $file = shift;
  68.     local $/ = undef;
  69.     open(CAT,$file) || die "Cannot open $file:$!";
  70.     my $result = <CAT>;
  71.     close(CAT);
  72.     return $result;
  73. }
  75. sub touch
  76. {
  77.     my $file = shift ;
  78.     open(CAT,">$file") || die "Cannot open $file:$!";
  79.     close(CAT);
  80. }
  82. sub joiner
  83. {
  84.     my $db = shift ;
  85.     my $sep = shift ;
  86.     my ($k, $v) = (0, "") ;
  87.     my @data = () ;
  89.     my $cursor = $db->db_cursor()  or return () ;
  90.     for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
  91.           $status == 0 ;
  92.           $status = $cursor->c_get($k, $v, DB_NEXT)) {
  93. push @data, $v ;
  94.     }
  96.     (scalar(@data), join($sep, @data)) ;
  97. }
  99. sub countRecords
  100. {
  101.    my $db = shift ;
  102.    my ($k, $v) = (0,0) ;
  103.    my ($count) = 0 ;
  104.    my ($cursor) = $db->db_cursor() ;
  105.    #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
  106. # $status == 0 ;
  107. # $status = $cursor->c_get($k, $v, DB_NEXT) )
  108.    while ($cursor->c_get($k, $v, DB_NEXT) == 0)
  109.      { ++ $count }
  111.    return $count ;
  112. }
  114. sub fillout
  115. {
  116.     my $var = shift ;
  117.     my $length = shift ;
  118.     my $pad = shift || " " ;
  119.     my $template = $pad x $length ;
  120.     substr($template, 0, length($var)) = $var ;
  121.     return $template ;
  122. }
  123.  
  124. my $Dfile = "dbhash.tmp";
  125. my $Dfile2 = "dbhash2.tmp";
  126. my $Dfile3 = "dbhash3.tmp";
  127. unlink $Dfile;
  129. umask(0) ;
  132. # Check for invalid parameters
  133. {
  134.     # Check for invalid parameters
  135.     my $db ;
  136.     eval ' $db = new BerkeleyDB::Queue  -Stupid => 3 ; ' ;
  137.     ok 1, $@ =~ /unknown key value(s) Stupid/  ;
  139.     eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
  140.     ok 2, $@ =~ /unknown key value(s) /  ;
  142.     eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
  143.     ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  145.     eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
  146.     ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
  148.     my $obj = bless [], "main" ;
  149.     eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
  150.     ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
  151. }
  153. # Now check the interface to Queue
  155. {
  156.     my $lex = new LexFile $Dfile ;
  157.     my $rec_len = 10 ;
  158.     my $pad = "x" ;
  160.     ok 6, my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
  161.     -Flags    => DB_CREATE,
  162.     -Len      => $rec_len,
  163.     -Pad      => $pad;
  165.     # Add a k/v pair
  166.     my $value ;
  167.     my $status ;
  168.     ok 7, $db->db_put(1, "some value") == 0  ;
  169.     ok 8, $db->status() == 0 ;
  170.     ok 9, $db->db_get(1, $value) == 0 ;
  171.     ok 10, $value eq fillout("some value", $rec_len, $pad) ;
  172.     ok 11, $db->db_put(2, "value") == 0  ;
  173.     ok 12, $db->db_get(2, $value) == 0 ;
  174.     ok 13, $value eq fillout("value", $rec_len, $pad) ;
  175.     ok 14, $db->db_del(1) == 0 ;
  176.     ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
  177.     ok 16, $db->status() == DB_KEYEMPTY ;
  178.     ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
  180.     ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
  181.     ok 19, $db->status() == DB_NOTFOUND ;
  182.     ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
  184.     ok 21, $db->db_sync() == 0 ;
  186.     # Check NOOVERWRITE will make put fail when attempting to overwrite
  187.     # an existing record.
  189.     ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
  190.     ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
  191.     ok 24, $db->status() == DB_KEYEXIST ;
  194.     # check that the value of the key  has not been changed by the
  195.     # previous test
  196.     ok 25, $db->db_get(2, $value) == 0 ;
  197.     ok 26, $value eq fillout("value", $rec_len, $pad) ;
  200. }
  203. {
  204.     # Check simple env works with a array.
  205.     # and pad defaults to space
  206.     my $lex = new LexFile $Dfile ;
  208.     my $home = "./fred" ;
  209.     my $rec_len = 11 ;
  210.     ok 27, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;
  212.     ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
  213.       -Home => $home ;
  215.     ok 29, my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
  216.     -Env      => $env,
  217.     -Flags    => DB_CREATE,
  218.     -Len      => $rec_len;
  220.     # Add a k/v pair
  221.     my $value ;
  222.     ok 30, $db->db_put(1, "some value") == 0 ;
  223.     ok 31, $db->db_get(1, $value) == 0 ;
  224.     ok 32, $value eq fillout("some value", $rec_len)  ;
  225.     undef $db ;
  226.     undef $env ;
  227.     rmtree $home ;
  228. }
  230.  
  231. {
  232.     # cursors
  234.     my $lex = new LexFile $Dfile ;
  235.     my @array ;
  236.     my ($k, $v) ;
  237.     my $rec_len = 5 ;
  238.     ok 33, my $db = new BerkeleyDB::Queue -Filename  => $Dfile, 
  239.        -ArrayBase => 0,
  240.        -Flags     => DB_CREATE ,
  241.        -Len       => $rec_len;
  243.     # create some data
  244.     my @data =  (
  245. "red" ,
  246. "green" ,
  247. "blue" ,
  248. ) ;
  250.     my $i ;
  251.     my %data ;
  252.     my $ret = 0 ;
  253.     for ($i = 0 ; $i < @data ; ++$i) {
  254.         $ret += $db->db_put($i, $data[$i]) ;
  255. $data{$i} = $data[$i] ;
  256.     }
  257.     ok 34, $ret == 0 ;
  259.     # create the cursor
  260.     ok 35, my $cursor = $db->db_cursor() ;
  262.     $k = 0 ; $v = "" ;
  263.     my %copy = %data;
  264.     my $extras = 0 ;
  265.     # sequence forwards
  266.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) 
  267.     {
  268.         if ( fillout($copy{$k}, $rec_len) eq $v ) 
  269.             { delete $copy{$k} }
  270. else
  271.     { ++ $extras }
  272.     }
  274.     ok 36, $cursor->status() == DB_NOTFOUND ;
  275.     ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
  276.     ok 38, keys %copy == 0 ;
  277.     ok 39, $extras == 0 ;
  279.     # sequence backwards
  280.     %copy = %data ;
  281.     $extras = 0 ;
  282.     my $status ;
  283.     for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
  284.   $status == 0 ;
  285.        $status = $cursor->c_get($k, $v, DB_PREV)) {
  286.         if ( fillout($copy{$k}, $rec_len) eq $v ) 
  287.             { delete $copy{$k} }
  288. else
  289.     { ++ $extras }
  290.     }
  291.     ok 40, $status == DB_NOTFOUND ;
  292.     ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
  293.     ok 42, $cursor->status() == $status ;
  294.     ok 43, $cursor->status() eq $status ;
  295.     ok 44, keys %copy == 0 ;
  296.     ok 45, $extras == 0 ;
  297. }
  298.  
  299. {
  300.     # Tied Array interface
  302.     # full tied array support started in Perl 5.004_57
  303.     # just double check.
  304.     my $FA = 0 ;
  305.     {
  306.         sub try::TIEARRAY { bless [], "try" }
  307.         sub try::FETCHSIZE { $FA = 1 }
  308.         my @a ; 
  309.         tie @a, 'try' ;
  310.         my $a = @a ;
  311.     }
  313.     my $lex = new LexFile $Dfile ;
  314.     my @array ;
  315.     my $db ;
  316.     my $rec_len = 10 ;
  317.     ok 46, $db = tie @array, 'BerkeleyDB::Queue', -Filename  => $Dfile,
  318.          -ArrayBase => 0,
  319.                                             -Flags     => DB_CREATE ,
  320.          -Len       => $rec_len;
  322.     ok 47, my $cursor = (tied @array)->db_cursor() ;
  323.     # check the database is empty
  324.     my $count = 0 ;
  325.     my ($k, $v) = (0,"") ;
  326.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  327. ++ $count ;
  328.     }
  329.     ok 48, $cursor->status() == DB_NOTFOUND ;
  330.     ok 49, $count == 0 ;
  332.     ok 50, @array == 0 ;
  334.     # Add a k/v pair
  335.     my $value ;
  336.     $array[1] = "some value";
  337.     ok 51, (tied @array)->status() == 0 ;
  338.     ok 52, $array[1] eq fillout("some value", $rec_len);
  339.     ok 53, defined $array[1];
  340.     ok 54, (tied @array)->status() == 0 ;
  341.     ok 55, !defined $array[3];
  342.     ok 56, (tied @array)->status() == DB_NOTFOUND ;
  344.     ok 57, (tied @array)->db_del(1) == 0 ;
  345.     ok 58, (tied @array)->status() == 0 ;
  346.     ok 59, ! defined $array[1];
  347.     ok 60, (tied @array)->status() == DB_KEYEMPTY ;
  349.     $array[1] = 2 ;
  350.     $array[10] = 20 ;
  351.     $array[1000] = 2000 ;
  353.     my ($keys, $values) = (0,0);
  354.     $count = 0 ;
  355.     for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
  356.   $status == 0 ;
  357.        $status = $cursor->c_get($k, $v, DB_NEXT)) {
  358.         $keys += $k ;
  359. $values += $v ;
  360. ++ $count ;
  361.     }
  362.     ok 61, $count == 3 ;
  363.     ok 62, $keys == 1011 ;
  364.     ok 63, $values == 2022 ;
  366.     # unshift isn't allowed
  367. #    eval {
  368. #     $FA ? unshift @array, "red", "green", "blue" 
  369. #        : $db->unshift("red", "green", "blue" ) ;
  370. # } ;
  371. #    ok 64, $@ =~ /^unshift is unsupported with Queue databases/ ;
  372.     $array[0] = "red" ;
  373.     $array[1] = "green" ;
  374.     $array[2] = "blue" ;
  375.     $array[4] = 2 ;
  376.     ok 64, $array[0] eq fillout("red", $rec_len) ;
  377.     ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
  378.     ok 66, $k == 0 ;
  379.     ok 67, $v eq fillout("red", $rec_len) ;
  380.     ok 68, $array[1] eq fillout("green", $rec_len) ;
  381.     ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  382.     ok 70, $k == 1 ;
  383.     ok 71, $v eq fillout("green", $rec_len) ;
  384.     ok 72, $array[2] eq fillout("blue", $rec_len) ;
  385.     ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  386.     ok 74, $k == 2 ;
  387.     ok 75, $v eq fillout("blue", $rec_len) ;
  388.     ok 76, $array[4] == 2 ;
  389.     ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
  390.     ok 78, $k == 4 ;
  391.     ok 79, $v == 2 ;
  393.     # shift
  394.     ok 80, ($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len) ;
  395.     ok 81, ($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len) ;
  396.     ok 82, ($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len) ;
  397.     ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
  399.     # push
  400.     $FA ? push @array, "the", "end" 
  401.         : $db->push("the", "end") ;
  402.     ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
  403.     ok 85, $k == 1002 ;
  404.     ok 86, $v eq fillout("end", $rec_len) ;
  405.     ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
  406.     ok 88, $k == 1001 ;
  407.     ok 89, $v eq fillout("the", $rec_len) ;
  408.     ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
  409.     ok 91, $k == 1000 ;
  410.     ok 92, $v == 2000 ;
  412.     # pop
  413.     ok 93, ( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len) ;
  414.     ok 94, ( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len) ;
  415.     ok 95, ( $FA ? pop @array : $db->pop ) == 2000  ;
  417.     # now clear the array 
  418.     $FA ? @array = () 
  419.         : $db->clear() ;
  420.     ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
  422.     undef $cursor ;
  423.     undef $db ;
  424.     untie @array ;
  425. }
  427. {
  428.     # in-memory file
  430.     my @array ;
  431.     my $fd ;
  432.     my $value ;
  433.     my $rec_len = 15 ;
  434.     ok 97, my $db = tie @array, 'BerkeleyDB::Queue',
  435.          -Len       => $rec_len;
  437.     ok 98, $db->db_put(1, "some value") == 0  ;
  438.     ok 99, $db->db_get(1, $value) == 0 ;
  439.     ok 100, $value eq fillout("some value", $rec_len) ;
  441. }
  442.  
  443. {
  444.     # partial
  445.     # check works via API
  447.     my $lex = new LexFile $Dfile ;
  448.     my $value ;
  449.     my $rec_len = 8 ;
  450.     ok 101, my $db = new BerkeleyDB::Queue  -Filename => $Dfile,
  451.                                            -Flags    => DB_CREATE ,
  452.          -Len      => $rec_len,
  453.          -Pad      => " " ;
  455.     # create some data
  456.     my @data =  (
  457. "",
  458. "boat",
  459. "house",
  460. "sea",
  461. ) ;
  463.     my $ret = 0 ;
  464.     my $i ;
  465.     for ($i = 0 ; $i < @data ; ++$i) {
  466.         my $r = $db->db_put($i, $data[$i]) ;
  467.         $ret += $r ;
  468.     }
  469.     ok 102, $ret == 0 ;
  471.     # do a partial get
  472.     my ($pon, $off, $len) = $db->partial_set(0,2) ;
  473.     ok 103, ! $pon && $off == 0 && $len == 0 ;
  474.     ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
  475.     ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
  476.     ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
  478.     # do a partial get, off end of data
  479.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  480.     ok 107, $pon ;
  481.     ok 108, $off == 0 ;
  482.     ok 109, $len == 2 ;
  483.     ok 110, $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
  484.     ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
  485.     ok 112, $db->db_get(3, $value) == 0 && $value eq "  " ;
  487.     # switch of partial mode
  488.     ($pon, $off, $len) = $db->partial_clear() ;
  489.     ok 113, $pon ;
  490.     ok 114, $off == 3 ;
  491.     ok 115, $len == 2 ;
  492.     ok 116, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
  493.     ok 117, $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
  494.     ok 118, $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;
  496.     # now partial put
  497.     $db->partial_set(0,2) ;
  498.     ok 119, $db->db_put(1, "") != 0 ;
  499.     ok 120, $db->db_put(2, "AB") == 0 ;
  500.     ok 121, $db->db_put(3, "XY") == 0 ;
  501.     ok 122, $db->db_put(4, "KLM") != 0 ;
  502.     ok 123, $db->db_put(4, "KL") == 0 ;
  504.     ($pon, $off, $len) = $db->partial_clear() ;
  505.     ok 124, $pon ;
  506.     ok 125, $off == 0 ;
  507.     ok 126, $len == 2 ;
  508.     ok 127, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
  509.     ok 128, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
  510.     ok 129, $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
  511.     ok 130, $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;
  513.     # now partial put
  514.     ($pon, $off, $len) = $db->partial_set(3,2) ;
  515.     ok 131, ! $pon ;
  516.     ok 132, $off == 0 ;
  517.     ok 133, $len == 0 ;
  518.     ok 134, $db->db_put(1, "PP") == 0 ;
  519.     ok 135, $db->db_put(2, "Q") != 0 ;
  520.     ok 136, $db->db_put(3, "XY") == 0 ;
  521.     ok 137, $db->db_put(4, "TU") == 0 ;
  523.     $db->partial_clear() ;
  524.     ok 138, $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
  525.     ok 139, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
  526.     ok 140, $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
  527.     ok 141, $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
  528. }
  530. {
  531.     # partial
  532.     # check works via tied array 
  534.     my $lex = new LexFile $Dfile ;
  535.     my @array ;
  536.     my $value ;
  537.     my $rec_len = 8 ;
  538.     ok 142, my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
  539.                                                -Flags    => DB_CREATE ,
  540.              -Len       => $rec_len,
  541.              -Pad       => " " ;
  543.     # create some data
  544.     my @data =  (
  545. "",
  546. "boat",
  547. "house",
  548. "sea",
  549. ) ;
  551.     my $i ;
  552.     my $status = 0 ;
  553.     for ($i = 1 ; $i < @data ; ++$i) {
  554. $array[$i] = $data[$i] ;
  555. $status += $db->status() ;
  556.     }
  558.     ok 143, $status == 0 ;
  560.     # do a partial get
  561.     $db->partial_set(0,2) ;
  562.     ok 144, $array[1] eq fillout("bo", 2) ;
  563.     ok 145, $array[2] eq fillout("ho", 2) ;
  564.     ok 146, $array[3]  eq fillout("se", 2) ;
  566.     # do a partial get, off end of data
  567.     $db->partial_set(3,2) ;
  568.     ok 147, $array[1] eq fillout("t", 2) ;
  569.     ok 148, $array[2] eq fillout("se", 2) ;
  570.     ok 149, $array[3] eq fillout("", 2) ;
  572.     # switch of partial mode
  573.     $db->partial_clear() ;
  574.     ok 150, $array[1] eq fillout("boat", $rec_len) ;
  575.     ok 151, $array[2] eq fillout("house", $rec_len) ;
  576.     ok 152, $array[3] eq fillout("sea", $rec_len) ;
  578.     # now partial put
  579.     $db->partial_set(0,2) ;
  580.     $array[1] = "" ;
  581.     ok 153, $db->status() != 0 ;
  582.     $array[2] = "AB" ;
  583.     ok 154, $db->status() == 0 ;
  584.     $array[3] = "XY" ;
  585.     ok 155, $db->status() == 0 ;
  586.     $array[4] = "KL" ;
  587.     ok 156, $db->status() == 0 ;
  589.     $db->partial_clear() ;
  590.     ok 157, $array[1] eq fillout("boat", $rec_len) ;
  591.     ok 158, $array[2] eq fillout("ABuse", $rec_len) ;
  592.     ok 159, $array[3] eq fillout("XYa", $rec_len) ;
  593.     ok 160, $array[4] eq fillout("KL", $rec_len) ;
  595.     # now partial put
  596.     $db->partial_set(3,2) ;
  597.     $array[1] = "PP" ;
  598.     ok 161, $db->status() == 0 ;
  599.     $array[2] = "Q" ;
  600.     ok 162, $db->status() != 0 ;
  601.     $array[3] = "XY" ;
  602.     ok 163, $db->status() == 0 ;
  603.     $array[4] = "TU" ;
  604.     ok 164, $db->status() == 0 ;
  606.     $db->partial_clear() ;
  607.     ok 165, $array[1] eq fillout("boaPP", $rec_len) ;
  608.     ok 166, $array[2] eq fillout("ABuse", $rec_len) ;
  609.     ok 167, $array[3] eq fillout("XYaXY", $rec_len) ;
  610.     ok 168, $array[4] eq fillout("KL TU", $rec_len) ;
  611. }
  613. {
  614.     # transaction
  616.     my $lex = new LexFile $Dfile ;
  617.     my @array ;
  618.     my $value ;
  620.     my $home = "./fred" ;
  621.     rmtree $home if -e $home ;
  622.     ok 169, mkdir($home, 0777) ;
  623.     my $rec_len = 9 ;
  624.     ok 170, my $env = new BerkeleyDB::Env -Home => $home,
  625.      -Flags => DB_CREATE|DB_INIT_TXN|
  626.    DB_INIT_MPOOL|DB_INIT_LOCK ;
  627.     ok 171, my $txn = $env->txn_begin() ;
  628.     ok 172, my $db1 = tie @array, 'BerkeleyDB::Queue', 
  629. -Filename => $Dfile,
  630. -ArrayBase => 0,
  631.                        -Flags    =>  DB_CREATE ,
  632.          -Env    => $env,
  633.          -Txn   => $txn ,
  634. -Len      => $rec_len,
  635. -Pad      => " " ;
  637.     
  638.     # create some data
  639.     my @data =  (
  640. "boat",
  641. "house",
  642. "sea",
  643. ) ;
  645.     my $ret = 0 ;
  646.     my $i ;
  647.     for ($i = 0 ; $i < @data ; ++$i) {
  648.         $ret += $db1->db_put($i, $data[$i]) ;
  649.     }
  650.     ok 173, $ret == 0 ;
  652.     # should be able to see all the records
  654.     ok 174, my $cursor = $db1->db_cursor() ;
  655.     my ($k, $v) = (0, "") ;
  656.     my $count = 0 ;
  657.     # sequence forwards
  658.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  659.         ++ $count ;
  660.     }
  661.     ok 175, $count == 3 ;
  662.     undef $cursor ;
  664.     # now abort the transaction
  665.     ok 176, $txn->txn_abort() == 0 ;
  667.     # there shouldn't be any records in the database
  668.     $count = 0 ;
  669.     # sequence forwards
  670.     ok 177, $cursor = $db1->db_cursor() ;
  671.     while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
  672.         ++ $count ;
  673.     }
  674.     ok 178, $count == 0 ;
  676.     undef $txn ;
  677.     undef $cursor ;
  678.     undef $db1 ;
  679.     undef $env ;
  680.     untie @array ;
  681.     rmtree $home ;
  682. }
  685. {
  686.     # db_stat
  688.     my $lex = new LexFile $Dfile ;
  689.     my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ;
  690.     my @array ;
  691.     my ($k, $v) ;
  692.     my $rec_len = 7 ;
  693.     ok 179, my $db = new BerkeleyDB::Queue -Filename  => $Dfile, 
  694.          -Flags     => DB_CREATE,
  695.    -Pagesize => 4 * 1024,
  696.            -Len       => $rec_len,
  697.            -Pad       => " " 
  698. ;
  700.     my $ref = $db->db_stat() ; 
  701.     ok 180, $ref->{$recs} == 0;
  702.     ok 181, $ref->{'qs_pagesize'} == 4 * 1024;
  704.     # create some data
  705.     my @data =  (
  706. 2,
  707. "house",
  708. "sea",
  709. ) ;
  711.     my $ret = 0 ;
  712.     my $i ;
  713.     for ($i = $db->ArrayOffset ; @data ; ++$i) {
  714.         $ret += $db->db_put($i, shift @data) ;
  715.     }
  716.     ok 182, $ret == 0 ;
  718.     $ref = $db->db_stat() ; 
  719.     ok 183, $ref->{$recs} == 3;
  720. }
  722. {
  723.    # sub-class test
  725.    package Another ;
  727.    use strict ;
  729.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  730.    print FILE <<'EOM' ;
  732.    package SubDB ;
  734.    use strict ;
  735.    use vars qw( @ISA @EXPORT) ;
  737.    require Exporter ;
  738.    use BerkeleyDB;
  739.    @ISA=qw(BerkeleyDB::Queue);
  740.    @EXPORT = @BerkeleyDB::EXPORT ;
  742.    sub db_put { 
  743. my $self = shift ;
  744.         my $key = shift ;
  745.         my $value = shift ;
  746.         $self->SUPER::db_put($key, $value * 3) ;
  747.    }
  749.    sub db_get { 
  750. my $self = shift ;
  751.         $self->SUPER::db_get($_[0], $_[1]) ;
  752. $_[1] -= 2 ;
  753.    }
  755.    sub A_new_method
  756.    {
  757. my $self = shift ;
  758.         my $key = shift ;
  759.         my $value = $self->FETCH($key) ;
  760. return "[[$value]]" ;
  761.    }
  763.    1 ;
  764. EOM
  766.     close FILE ;
  768.     BEGIN { push @INC, '.'; }    
  769.     eval 'use SubDB ; ';
  770.     main::ok 184, $@ eq "" ;
  771.     my @h ;
  772.     my $X ;
  773.     my $rec_len = 34 ;
  774.     eval '
  775. $X = tie(@h, "SubDB", -Filename => "dbbtree.tmp", 
  776. -Flags => DB_CREATE,
  777. -Mode => 0640 ,
  778.                 -Len       => $rec_len,
  779.                 -Pad       => " " 
  780. );    
  781. ' ;
  783.     main::ok 185, $@ eq "" ;
  785.     my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
  786.     main::ok 186, $@ eq "" ;
  787.     main::ok 187, $ret == 7 ;
  789.     my $value = 0;
  790.     $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
  791.     main::ok 188, $@ eq "" ;
  792.     main::ok 189, $ret == 10 ;
  794.     $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
  795.     main::ok 190, $@ eq ""  ;
  796.     main::ok 191, $ret == 1 ;
  798.     $ret = eval '$X->A_new_method(1) ' ;
  799.     main::ok 192, $@ eq "" ;
  800.     main::ok 193, $ret eq "[[10]]" ;
  802.     unlink "SubDB.pm", "dbbtree.tmp" ;
  804. }
  806. {
  807.     # DB_APPEND
  809.     my $lex = new LexFile $Dfile;
  810.     my @array ;
  811.     my $value ;
  812.     my $rec_len = 21 ;
  813.     ok 194, my $db = tie @array, 'BerkeleyDB::Queue', 
  814. -Filename  => $Dfile,
  815.                                         -Flags     => DB_CREATE ,
  816.                  -Len       => $rec_len,
  817.                  -Pad       => " " ;
  819.     # create a few records
  820.     $array[1] = "def" ;
  821.     $array[3] = "ghi" ;
  823.     my $k = 0 ;
  824.     ok 195, $db->db_put($k, "fred", DB_APPEND) == 0 ;
  825.     ok 196, $k == 4 ;
  826.     ok 197, $array[4] eq fillout("fred", $rec_len) ;
  828.     undef $db ;
  829.     untie @array ;
  830. }
  832. __END__
  835. # TODO
  836. #
  837. # DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records