proc test063 { method args } {
global errorCode
source ./include.tcl
set args [convert_args $method $args]
set omethod [convert_method $method]
set tnum "063"
set txnenv 0
set eindex [lsearch -exact $args "-env"]
if { $eindex == -1 } {
set testfile $testdir/test$tnum.db
set env NULL
} else {
set testfile test$tnum.db
incr eindex
set env [lindex $args $eindex]
set txnenv [is_txnenv $env]
if { $txnenv == 1 } {
append args " -auto_commit "
}
set testdir [get_home $env]
}
cleanup $testdir $env
set key "key"
set data "data"
set key2 "another_key"
set data2 "more_data"
set gflags ""
set txn ""
if { [is_record_based $method] == 1 } {
set key "1"
set key2 "2"
append gflags " -recno"
}
puts "Test$tnum: $method ($args) DB_RDONLY test."
puts "\tTest$tnum.a: Creating test database."
set db [eval {berkdb_open_noerr -create -mode 0644} \
$omethod $args $testfile]
error_check_good db_create [is_valid_db $db] TRUE
if { $txnenv == 1 } {
set t [$env txn]
error_check_good txn [is_valid_txn $t $env] TRUE
set txn "-txn $t"
}
set ret [eval {$db put} $txn {$key [chop_data $method $data]}]
error_check_good initial_put $ret 0
set dbt [eval {$db get} $txn $gflags {$key}]
error_check_good initial_get $dbt \
[list [list $key [pad_data $method $data]]]
if { $txnenv == 1 } {
error_check_good txn [$t commit] 0
}
error_check_good db_close [$db close] 0
if { $eindex == -1 } {
error_check_good writable [file writable $testfile] 1
}
puts "\tTest$tnum.b: Re-opening DB_RDONLY and attempting to put."
set db [eval {berkdb_open_noerr -rdonly} $args {$testfile}]
error_check_good db_open [is_valid_db $db] TRUE
if { $txnenv == 1 } {
set t [$env txn]
error_check_good txn [is_valid_txn $t $env] TRUE
set txn "-txn $t"
}
set dbt [eval {$db get} $txn $gflags {$key}]
error_check_good db_get $dbt \
[list [list $key [pad_data $method $data]]]
set ret [catch {eval {$db put} $txn \
{$key2 [chop_data $method $data]}} res]
error_check_good put_failed $ret 1
error_check_good db_put_rdonly [is_substr $errorCode "EACCES"] 1
if { $txnenv == 1 } {
error_check_good txn [$t commit] 0
}
set errorCode "NONE"
puts "\tTest$tnum.c: Attempting cursor put."
if { $txnenv == 1 } {
set t [$env txn]
error_check_good txn [is_valid_txn $t $env] TRUE
set txn "-txn $t"
}
set dbc [eval {$db cursor} $txn]
error_check_good cursor_create [is_valid_cursor $dbc $db] TRUE
error_check_good cursor_set [$dbc get -first] $dbt
set ret [catch {eval {$dbc put} -current $data} res]
error_check_good c_put_failed $ret 1
error_check_good dbc_put_rdonly [is_substr $errorCode "EACCES"] 1
set dbt [eval {$db get} $gflags {$key2}]
error_check_good db_get_key2 $dbt ""
puts "\tTest$tnum.d: Attempting ordinary delete."
set errorCode "NONE"
set ret [catch {eval {$db del} $txn {$key}} 1]
error_check_good del_failed $ret 1
error_check_good db_del_rdonly [is_substr $errorCode "EACCES"] 1
set dbt [eval {$db get} $txn $gflags {$key}]
error_check_good db_get_key $dbt \
[list [list $key [pad_data $method $data]]]
puts "\tTest$tnum.e: Attempting cursor delete."
set dbt2 [$dbc get -first]
error_check_good db_get_first_key $dbt2 $dbt
set errorCode "NONE"
set ret [catch {$dbc del} res]
error_check_good c_del_failed $ret 1
error_check_good dbc_del_rdonly [is_substr $errorCode "EACCES"] 1
set dbt2 [$dbc get -current]
error_check_good db_get_key $dbt2 $dbt
puts "\tTest$tnum.f: Close, reopen db; verify unchanged."
error_check_good dbc_close [$dbc close] 0
if { $txnenv == 1 } {
error_check_good txn [$t commit] 0
}
error_check_good db_close [$db close] 0
set db [eval {berkdb_open} $omethod $args $testfile]
error_check_good db_reopen [is_valid_db $db] TRUE
set dbc [$db cursor]
error_check_good cursor_create [is_valid_cursor $dbc $db] TRUE
error_check_good first_there [$dbc get -first] \
[list [list $key [pad_data $method $data]]]
error_check_good nomore_there [$dbc get -next] ""
error_check_good dbc_close [$dbc close] 0
error_check_good db_close [$db close] 0
}