summaryrefslogtreecommitdiff
path: root/bdb/perl.BerkeleyDB/t/recno.t
diff options
context:
space:
mode:
Diffstat (limited to 'bdb/perl.BerkeleyDB/t/recno.t')
-rw-r--r--bdb/perl.BerkeleyDB/t/recno.t967
1 files changed, 0 insertions, 967 deletions
diff --git a/bdb/perl.BerkeleyDB/t/recno.t b/bdb/perl.BerkeleyDB/t/recno.t
deleted file mode 100644
index 0f210f540c3..00000000000
--- a/bdb/perl.BerkeleyDB/t/recno.t
+++ /dev/null
@@ -1,967 +0,0 @@
-#!./perl -w
-
-# ID: %I%, %G%
-
-use strict ;
-
-BEGIN {
- unless(grep /blib/, @INC) {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
- }
-}
-
-use BerkeleyDB;
-use File::Path qw(rmtree);
-
-print "1..218\n";
-
-my %DB_errors = (
- 'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
- 'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
- 'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
- 'DB_LOCK_DEADLOCK' => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
- 'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
- 'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
- 'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade",
- 'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery",
-) ;
-
-{
- package LexFile ;
-
- sub new
- {
- my $self = shift ;
- unlink @_ ;
- bless [ @_ ], $self ;
- }
-
- sub DESTROY
- {
- my $self = shift ;
- unlink @{ $self } ;
- }
-}
-
-
-sub ok
-{
- my $no = shift ;
- my $result = shift ;
-
- print "not " unless $result ;
- print "ok $no\n" ;
-}
-
-sub docat
-{
- my $file = shift;
- local $/ = undef;
- open(CAT,$file) || die "Cannot open $file:$!";
- my $result = <CAT>;
- close(CAT);
- return $result;
-}
-
-sub touch
-{
- my $file = shift ;
- open(CAT,">$file") || die "Cannot open $file:$!";
- close(CAT);
-}
-
-sub joiner
-{
- my $db = shift ;
- my $sep = shift ;
- my ($k, $v) = (0, "") ;
- my @data = () ;
-
- my $cursor = $db->db_cursor() or return () ;
- for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
- $status == 0 ;
- $status = $cursor->c_get($k, $v, DB_NEXT)) {
- push @data, $v ;
- }
-
- (scalar(@data), join($sep, @data)) ;
-}
-
-sub countRecords
-{
- my $db = shift ;
- my ($k, $v) = (0,0) ;
- my ($count) = 0 ;
- my ($cursor) = $db->db_cursor() ;
- #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
-# $status == 0 ;
-# $status = $cursor->c_get($k, $v, DB_NEXT) )
- while ($cursor->c_get($k, $v, DB_NEXT) == 0)
- { ++ $count }
-
- return $count ;
-}
-
-my $Dfile = "dbhash.tmp";
-my $Dfile2 = "dbhash2.tmp";
-my $Dfile3 = "dbhash3.tmp";
-unlink $Dfile;
-
-umask(0) ;
-
-
-# Check for invalid parameters
-{
- # Check for invalid parameters
- my $db ;
- eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ;
- ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
-
- eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
- ok 2, $@ =~ /unknown key value\(s\) / ;
-
- eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ;
- ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
-
- eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ;
- ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
-
- my $obj = bless [], "main" ;
- eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ;
- ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
-}
-
-# Now check the interface to Recno
-
-{
- my $lex = new LexFile $Dfile ;
-
- ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
- -Flags => DB_CREATE ;
-
- # Add a k/v pair
- my $value ;
- my $status ;
- ok 7, $db->db_put(1, "some value") == 0 ;
- ok 8, $db->status() == 0 ;
- ok 9, $db->db_get(1, $value) == 0 ;
- ok 10, $value eq "some value" ;
- ok 11, $db->db_put(2, "value") == 0 ;
- ok 12, $db->db_get(2, $value) == 0 ;
- ok 13, $value eq "value" ;
- ok 14, $db->db_del(1) == 0 ;
- ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
- ok 16, $db->status() == DB_KEYEMPTY ;
- ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
-
- ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
- ok 19, $db->status() == DB_NOTFOUND ;
- ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
-
- ok 21, $db->db_sync() == 0 ;
-
- # Check NOOVERWRITE will make put fail when attempting to overwrite
- # an existing record.
-
- ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
- ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
- ok 24, $db->status() == DB_KEYEXIST ;
-
-
- # check that the value of the key has not been changed by the
- # previous test
- ok 25, $db->db_get(2, $value) == 0 ;
- ok 26, $value eq "value" ;
-
-
-}
-
-
-{
- # Check simple env works with a array.
- my $lex = new LexFile $Dfile ;
-
- my $home = "./fred" ;
- ok 27, -d $home ? chmod 0777, $home : mkdir($home, 0777) ;
-
- ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
- -Home => $home ;
-
- ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
- -Env => $env,
- -Flags => DB_CREATE ;
-
- # Add a k/v pair
- my $value ;
- ok 30, $db->db_put(1, "some value") == 0 ;
- ok 31, $db->db_get(1, $value) == 0 ;
- ok 32, $value eq "some value" ;
- undef $db ;
- undef $env ;
- rmtree $home ;
-}
-
-
-{
- # cursors
-
- my $lex = new LexFile $Dfile ;
- my @array ;
- my ($k, $v) ;
- ok 33, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ;
-
- # create some data
- my @data = (
- "red" ,
- "green" ,
- "blue" ,
- ) ;
-
- my $i ;
- my %data ;
- my $ret = 0 ;
- for ($i = 0 ; $i < @data ; ++$i) {
- $ret += $db->db_put($i, $data[$i]) ;
- $data{$i} = $data[$i] ;
- }
- ok 34, $ret == 0 ;
-
- # create the cursor
- ok 35, my $cursor = $db->db_cursor() ;
-
- $k = 0 ; $v = "" ;
- my %copy = %data;
- my $extras = 0 ;
- # sequence forwards
- while ($cursor->c_get($k, $v, DB_NEXT) == 0)
- {
- if ( $copy{$k} eq $v )
- { delete $copy{$k} }
- else
- { ++ $extras }
- }
-
- ok 36, $cursor->status() == DB_NOTFOUND ;
- ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
- ok 38, keys %copy == 0 ;
- ok 39, $extras == 0 ;
-
- # sequence backwards
- %copy = %data ;
- $extras = 0 ;
- my $status ;
- for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
- $status == 0 ;
- $status = $cursor->c_get($k, $v, DB_PREV)) {
- if ( $copy{$k} eq $v )
- { delete $copy{$k} }
- else
- { ++ $extras }
- }
- ok 40, $status == DB_NOTFOUND ;
- ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
- ok 42, $cursor->status() == $status ;
- ok 43, $cursor->status() eq $status ;
- ok 44, keys %copy == 0 ;
- ok 45, $extras == 0 ;
-}
-
-{
- # Tied Array interface
-
- # full tied array support started in Perl 5.004_57
- # just double check.
- my $FA = 0 ;
- {
- sub try::TIEARRAY { bless [], "try" }
- sub try::FETCHSIZE { $FA = 1 }
- my @a ;
- tie @a, 'try' ;
- my $a = @a ;
- }
-
- my $lex = new LexFile $Dfile ;
- my @array ;
- my $db ;
- ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -Property => DB_RENUMBER,
- -ArrayBase => 0,
- -Flags => DB_CREATE ;
-
- ok 47, my $cursor = (tied @array)->db_cursor() ;
- # check the database is empty
- my $count = 0 ;
- my ($k, $v) = (0,"") ;
- while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
- ++ $count ;
- }
- ok 48, $cursor->status() == DB_NOTFOUND ;
- ok 49, $count == 0 ;
-
- ok 50, @array == 0 ;
-
- # Add a k/v pair
- my $value ;
- $array[1] = "some value";
- ok 51, (tied @array)->status() == 0 ;
- ok 52, $array[1] eq "some value";
- ok 53, defined $array[1];
- ok 54, (tied @array)->status() == 0 ;
- ok 55, !defined $array[3];
- ok 56, (tied @array)->status() == DB_NOTFOUND ;
-
- ok 57, (tied @array)->db_del(1) == 0 ;
- ok 58, (tied @array)->status() == 0 ;
- ok 59, ! defined $array[1];
- ok 60, (tied @array)->status() == DB_NOTFOUND ;
-
- $array[1] = 2 ;
- $array[10] = 20 ;
- $array[1000] = 2000 ;
-
- my ($keys, $values) = (0,0);
- $count = 0 ;
- for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
- $status == 0 ;
- $status = $cursor->c_get($k, $v, DB_NEXT)) {
- $keys += $k ;
- $values += $v ;
- ++ $count ;
- }
- ok 61, $count == 3 ;
- ok 62, $keys == 1011 ;
- ok 63, $values == 2022 ;
-
- # unshift
- $FA ? unshift @array, "red", "green", "blue"
- : $db->unshift("red", "green", "blue" ) ;
- ok 64, $array[1] eq "red" ;
- ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
- ok 66, $k == 1 ;
- ok 67, $v eq "red" ;
- ok 68, $array[2] eq "green" ;
- ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
- ok 70, $k == 2 ;
- ok 71, $v eq "green" ;
- ok 72, $array[3] eq "blue" ;
- ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
- ok 74, $k == 3 ;
- ok 75, $v eq "blue" ;
- ok 76, $array[4] == 2 ;
- ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
- ok 78, $k == 4 ;
- ok 79, $v == 2 ;
-
- # shift
- ok 80, ($FA ? shift @array : $db->shift()) eq "red" ;
- ok 81, ($FA ? shift @array : $db->shift()) eq "green" ;
- ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ;
- ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
-
- # push
- $FA ? push @array, "the", "end"
- : $db->push("the", "end") ;
- ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
- ok 85, $k == 1001 ;
- ok 86, $v eq "end" ;
- ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
- ok 88, $k == 1000 ;
- ok 89, $v eq "the" ;
- ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
- ok 91, $k == 999 ;
- ok 92, $v == 2000 ;
-
- # pop
- ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ;
- ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ;
- ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ;
-
- # now clear the array
- $FA ? @array = ()
- : $db->clear() ;
- ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
-
- undef $cursor ;
- undef $db ;
- untie @array ;
-}
-
-{
- # in-memory file
-
- my @array ;
- my $fd ;
- my $value ;
- ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ;
-
- ok 98, $db->db_put(1, "some value") == 0 ;
- ok 99, $db->db_get(1, $value) == 0 ;
- ok 100, $value eq "some value" ;
-
-}
-
-{
- # partial
- # check works via API
-
- my $lex = new LexFile $Dfile ;
- my $value ;
- ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile,
- -Flags => DB_CREATE ;
-
- # create some data
- my @data = (
- "",
- "boat",
- "house",
- "sea",
- ) ;
-
- my $ret = 0 ;
- my $i ;
- for ($i = 1 ; $i < @data ; ++$i) {
- $ret += $db->db_put($i, $data[$i]) ;
- }
- ok 102, $ret == 0 ;
-
-
- # do a partial get
- my ($pon, $off, $len) = $db->partial_set(0,2) ;
- ok 103, ! $pon && $off == 0 && $len == 0 ;
- ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
- ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
- ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
-
- # do a partial get, off end of data
- ($pon, $off, $len) = $db->partial_set(3,2) ;
- ok 107, $pon ;
- ok 108, $off == 0 ;
- ok 109, $len == 2 ;
- ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ;
- ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
- ok 112, $db->db_get(3, $value) == 0 && $value eq "" ;
-
- # switch of partial mode
- ($pon, $off, $len) = $db->partial_clear() ;
- ok 113, $pon ;
- ok 114, $off == 3 ;
- ok 115, $len == 2 ;
- ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ;
- ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ;
- ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ;
-
- # now partial put
- $db->partial_set(0,2) ;
- ok 119, $db->db_put(1, "") == 0 ;
- ok 120, $db->db_put(2, "AB") == 0 ;
- ok 121, $db->db_put(3, "XYZ") == 0 ;
- ok 122, $db->db_put(4, "KLM") == 0 ;
-
- ($pon, $off, $len) = $db->partial_clear() ;
- ok 123, $pon ;
- ok 124, $off == 0 ;
- ok 125, $len == 2 ;
- ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ;
- ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
- ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
- ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ;
-
- # now partial put
- ($pon, $off, $len) = $db->partial_set(3,2) ;
- ok 130, ! $pon ;
- ok 131, $off == 0 ;
- ok 132, $len == 0 ;
- ok 133, $db->db_put(1, "PPP") == 0 ;
- ok 134, $db->db_put(2, "Q") == 0 ;
- ok 135, $db->db_put(3, "XYZ") == 0 ;
- ok 136, $db->db_put(4, "TU") == 0 ;
-
- $db->partial_clear() ;
- ok 137, $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
- ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
- ok 139, $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
- ok 140, $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
-}
-
-{
- # partial
- # check works via tied array
-
- my $lex = new LexFile $Dfile ;
- my @array ;
- my $value ;
- ok 141, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -Flags => DB_CREATE ;
-
- # create some data
- my @data = (
- "",
- "boat",
- "house",
- "sea",
- ) ;
-
- my $i ;
- for ($i = 1 ; $i < @data ; ++$i) {
- $array[$i] = $data[$i] ;
- }
-
-
- # do a partial get
- $db->partial_set(0,2) ;
- ok 142, $array[1] eq "bo" ;
- ok 143, $array[2] eq "ho" ;
- ok 144, $array[3] eq "se" ;
-
- # do a partial get, off end of data
- $db->partial_set(3,2) ;
- ok 145, $array[1] eq "t" ;
- ok 146, $array[2] eq "se" ;
- ok 147, $array[3] eq "" ;
-
- # switch of partial mode
- $db->partial_clear() ;
- ok 148, $array[1] eq "boat" ;
- ok 149, $array[2] eq "house" ;
- ok 150, $array[3] eq "sea" ;
-
- # now partial put
- $db->partial_set(0,2) ;
- ok 151, $array[1] = "" ;
- ok 152, $array[2] = "AB" ;
- ok 153, $array[3] = "XYZ" ;
- ok 154, $array[4] = "KLM" ;
-
- $db->partial_clear() ;
- ok 155, $array[1] eq "at" ;
- ok 156, $array[2] eq "ABuse" ;
- ok 157, $array[3] eq "XYZa" ;
- ok 158, $array[4] eq "KLM" ;
-
- # now partial put
- $db->partial_set(3,2) ;
- ok 159, $array[1] = "PPP" ;
- ok 160, $array[2] = "Q" ;
- ok 161, $array[3] = "XYZ" ;
- ok 162, $array[4] = "TU" ;
-
- $db->partial_clear() ;
- ok 163, $array[1] eq "at\0PPP" ;
- ok 164, $array[2] eq "ABuQ" ;
- ok 165, $array[3] eq "XYZXYZ" ;
- ok 166, $array[4] eq "KLMTU" ;
-}
-
-{
- # transaction
-
- my $lex = new LexFile $Dfile ;
- my @array ;
- my $value ;
-
- my $home = "./fred" ;
- rmtree $home if -e $home ;
- ok 167, mkdir($home, 0777) ;
- ok 168, my $env = new BerkeleyDB::Env -Home => $home,
- -Flags => DB_CREATE|DB_INIT_TXN|
- DB_INIT_MPOOL|DB_INIT_LOCK ;
- ok 169, my $txn = $env->txn_begin() ;
- ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno',
- -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Env => $env,
- -Txn => $txn ;
-
-
- # create some data
- my @data = (
- "boat",
- "house",
- "sea",
- ) ;
-
- my $ret = 0 ;
- my $i ;
- for ($i = 0 ; $i < @data ; ++$i) {
- $ret += $db1->db_put($i, $data[$i]) ;
- }
- ok 171, $ret == 0 ;
-
- # should be able to see all the records
-
- ok 172, my $cursor = $db1->db_cursor() ;
- my ($k, $v) = (0, "") ;
- my $count = 0 ;
- # sequence forwards
- while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
- ++ $count ;
- }
- ok 173, $count == 3 ;
- undef $cursor ;
-
- # now abort the transaction
- ok 174, $txn->txn_abort() == 0 ;
-
- # there shouldn't be any records in the database
- $count = 0 ;
- # sequence forwards
- ok 175, $cursor = $db1->db_cursor() ;
- while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
- ++ $count ;
- }
- ok 176, $count == 0 ;
-
- undef $txn ;
- undef $cursor ;
- undef $db1 ;
- undef $env ;
- untie @array ;
- rmtree $home ;
-}
-
-
-{
- # db_stat
-
- my $lex = new LexFile $Dfile ;
- my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
- my @array ;
- my ($k, $v) ;
- ok 177, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
- -Flags => DB_CREATE,
- -Pagesize => 4 * 1024,
- ;
-
- my $ref = $db->db_stat() ;
- ok 178, $ref->{$recs} == 0;
- ok 179, $ref->{'bt_pagesize'} == 4 * 1024;
-
- # create some data
- my @data = (
- 2,
- "house",
- "sea",
- ) ;
-
- my $ret = 0 ;
- my $i ;
- for ($i = $db->ArrayOffset ; @data ; ++$i) {
- $ret += $db->db_put($i, shift @data) ;
- }
- ok 180, $ret == 0 ;
-
- $ref = $db->db_stat() ;
- ok 181, $ref->{$recs} == 3;
-}
-
-{
- # sub-class test
-
- package Another ;
-
- use strict ;
-
- open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
- print FILE <<'EOM' ;
-
- package SubDB ;
-
- use strict ;
- use vars qw( @ISA @EXPORT) ;
-
- require Exporter ;
- use BerkeleyDB;
- @ISA=qw(BerkeleyDB::Recno);
- @EXPORT = @BerkeleyDB::EXPORT ;
-
- sub db_put {
- my $self = shift ;
- my $key = shift ;
- my $value = shift ;
- $self->SUPER::db_put($key, $value * 3) ;
- }
-
- sub db_get {
- my $self = shift ;
- $self->SUPER::db_get($_[0], $_[1]) ;
- $_[1] -= 2 ;
- }
-
- sub A_new_method
- {
- my $self = shift ;
- my $key = shift ;
- my $value = $self->FETCH($key) ;
- return "[[$value]]" ;
- }
-
- 1 ;
-EOM
-
- close FILE ;
-
- BEGIN { push @INC, '.'; }
- eval 'use SubDB ; ';
- main::ok 182, $@ eq "" ;
- my @h ;
- my $X ;
- eval '
- $X = tie(@h, "SubDB", -Filename => "dbbtree.tmp",
- -Flags => DB_CREATE,
- -Mode => 0640 );
- ' ;
-
- main::ok 183, $@ eq "" ;
-
- my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
- main::ok 184, $@ eq "" ;
- main::ok 185, $ret == 7 ;
-
- my $value = 0;
- $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
- main::ok 186, $@ eq "" ;
- main::ok 187, $ret == 10 ;
-
- $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
- main::ok 188, $@ eq "" ;
- main::ok 189, $ret == 1 ;
-
- $ret = eval '$X->A_new_method(1) ' ;
- main::ok 190, $@ eq "" ;
- main::ok 191, $ret eq "[[10]]" ;
-
- unlink "SubDB.pm", "dbbtree.tmp" ;
-
-}
-
-{
- # variable length records, DB_DELIMETER -- defaults to \n
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 192, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Source => $Dfile2 ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 193, $x eq "abc\ndef\n\nghi\n" ;
-}
-
-{
- # variable length records, change DB_DELIMETER
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 194, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Source => $Dfile2 ,
- -Delim => "-";
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 195, $x eq "abc-def--ghi-";
-}
-
-{
- # fixed length records, default DB_PAD
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 196, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Len => 5,
- -Source => $Dfile2 ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 197, $x eq "abc def ghi " ;
-}
-
-{
- # fixed length records, change Pad
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 198, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Len => 5,
- -Pad => "-",
- -Source => $Dfile2 ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 199, $x eq "abc--def-------ghi--" ;
-}
-
-{
- # DB_RENUMBER
-
- my $lex = new LexFile $Dfile;
- my @array ;
- my $value ;
- ok 200, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
- -Property => DB_RENUMBER,
- -ArrayBase => 0,
- -Flags => DB_CREATE ;
- # create a few records
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
-
- ok 201, my ($length, $joined) = joiner($db, "|") ;
- ok 202, $length == 3 ;
- ok 203, $joined eq "abc|def|ghi";
-
- ok 204, $db->db_del(1) == 0 ;
- ok 205, ($length, $joined) = joiner($db, "|") ;
- ok 206, $length == 2 ;
- ok 207, $joined eq "abc|ghi";
-
- undef $db ;
- untie @array ;
-
-}
-
-{
- # DB_APPEND
-
- my $lex = new LexFile $Dfile;
- my @array ;
- my $value ;
- ok 208, my $db = tie @array, 'BerkeleyDB::Recno',
- -Filename => $Dfile,
- -Flags => DB_CREATE ;
-
- # create a few records
- $array[1] = "def" ;
- $array[3] = "ghi" ;
-
- my $k = 0 ;
- ok 209, $db->db_put($k, "fred", DB_APPEND) == 0 ;
- ok 210, $k == 4 ;
-
- undef $db ;
- untie @array ;
-}
-
-{
- # in-memory Btree with an associated text file
-
- my $lex = new LexFile $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 211, tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 ,
- -ArrayBase => 0,
- -Property => DB_RENUMBER,
- -Flags => DB_CREATE ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 212, $x eq "abc\ndef\n\nghi\n" ;
-}
-
-{
- # in-memory, variable length records, change DB_DELIMETER
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 213, tie @array, 'BerkeleyDB::Recno',
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Source => $Dfile2 ,
- -Property => DB_RENUMBER,
- -Delim => "-";
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 214, $x eq "abc-def--ghi-";
-}
-
-{
- # in-memory, fixed length records, default DB_PAD
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 215, tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Property => DB_RENUMBER,
- -Len => 5,
- -Source => $Dfile2 ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 216, $x eq "abc def ghi " ;
-}
-
-{
- # in-memory, fixed length records, change Pad
-
- my $lex = new LexFile $Dfile, $Dfile2 ;
- touch $Dfile2 ;
- my @array ;
- my $value ;
- ok 217, tie @array, 'BerkeleyDB::Recno',
- -ArrayBase => 0,
- -Flags => DB_CREATE ,
- -Property => DB_RENUMBER,
- -Len => 5,
- -Pad => "-",
- -Source => $Dfile2 ;
- $array[0] = "abc" ;
- $array[1] = "def" ;
- $array[3] = "ghi" ;
- untie @array ;
-
- my $x = docat($Dfile2) ;
- ok 218, $x eq "abc--def-------ghi--" ;
-}
-
-__END__
-
-
-# TODO
-#
-# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
View Lorry Controller Status