proc do_op {omethod op names txn env {largs ""}} {
switch -exact $op {
delete { do_delete $names }
rename { do_rename $names $txn $env }
remove { do_remove $names $txn $env }
noop { do_noop }
open_create { do_create $omethod $names $txn $env $largs }
open { do_open $omethod $names $txn $env $largs }
open_excl { do_create_excl $omethod $names $txn $env $largs }
truncate { do_truncate $omethod $names $txn $env $largs }
default { puts "FAIL: operation $op not recognized" }
}
}
proc do_subdb_op {omethod op names txn env {largs ""}} {
switch -exact $op {
delete { do_delete $names }
rename { do_subdb_rename $names $txn $env }
remove { do_subdb_remove $names $txn $env }
noop { do_noop }
default { puts "FAIL: operation $op not recognized" }
}
}
proc do_inmem_op {omethod op names txn env {largs ""}} {
switch -exact $op {
delete { do_delete $names }
rename { do_inmem_rename $names $txn $env }
remove { do_inmem_remove $names $txn $env }
noop { do_noop }
open_create { do_inmem_create $omethod $names $txn $env $largs }
open { do_inmem_open $omethod $names $txn $env $largs }
open_excl { do_inmem_create_excl $omethod $names $txn $env $largs }
truncate { do_inmem_truncate $omethod $names $txn $env $largs }
default { puts "FAIL: operation $op not recognized" }
}
}
proc do_delete {names} {
global testdir
if {[catch [fileremove -f $testdir/$names] result]} {
return $result
} else {
return 0
}
}
proc do_noop { } {
return 0
}
proc do_rename {names txn env} {
set oldname [lindex $names 0]
set newname [lindex $names 1]
if {[catch {eval $env dbrename -txn $txn \
$oldname $newname} result]} {
return $result
} else {
return 0
}
}
proc do_subdb_rename {names txn env} {
set filename [lindex $names 0]
set oldsname [lindex $names 1]
set newsname [lindex $names 2]
if {[catch {eval $env dbrename -txn $txn $filename \
$oldsname $newsname} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_rename {names txn env} {
set filename ""
set oldsname [lindex $names 0]
set newsname [lindex $names 1]
if {[catch {eval $env dbrename -txn $txn {$filename} \
$oldsname $newsname} result]} {
return $result
} else {
return 0
}
}
proc do_remove {names txn env} {
if {[catch {eval $env dbremove -txn $txn $names} result]} {
return $result
} else {
return 0
}
}
proc do_subdb_remove {names txn env} {
set filename [lindex $names 0]
set subname [lindex $names 1]
if {[catch {eval $env dbremove -txn $txn $filename $subname} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_remove {names txn env} {
if {[catch {eval $env dbremove -txn $txn {""} $names} result]} {
return $result
} else {
return 0
}
}
proc do_create {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open -create $omethod $largs -env $env \
-txn $txn $names} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_create {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open -create $omethod $largs -env $env \
-txn $txn "" $names} result]} {
return $result
} else {
return 0
}
}
proc do_open {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open $omethod $largs -env $env \
-txn $txn $names} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_open {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open $omethod $largs -env $env \
-txn $txn {""} $names} result]} {
return $result
} else {
return 0
}
}
proc do_create_excl {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open -create -excl $omethod $largs -env $env \
-txn $txn $names} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_create_excl {omethod names txn env {largs ""}} {
if {[catch {eval berkdb_open -create -excl $omethod $largs -env $env \
-txn $txn {""} $names} result]} {
return $result
} else {
return 0
}
}
proc do_truncate {omethod names txn env {largs ""}} {
set db [eval {berkdb_open $omethod} $largs {-env $env -txn $txn $names}]
error_check_good db_open [is_valid_db $db] TRUE
if {[catch {$db truncate -txn $txn} result]} {
return $result
} else {
return 0
}
}
proc do_inmem_truncate {omethod names txn env {largs ""}} {
set db [eval {berkdb_open $omethod} $largs {-env $env -txn $txn "" $names}]
error_check_good db_open [is_valid_db $db] TRUE
if {[catch {$db truncate -txn $txn} result]} {
return $result
} else {
return 0
}
}
proc create_tests { op1 op2 exists noexist open retval { end1 "" } } {
set retlist {}
switch $op1 {
rename {
set from [lindex $exists 0]
set to [lindex $noexist 0]
set op1ret [list $op1 "$from $to" 0 $end1]
if { $end1 != "abort" } {
set exists [lreplace $exists 0 0 $to]
set noexist [lreplace $noexist 0 0 $from]
}
}
remove {
set from [lindex $exists 0]
set op1ret [list $op1 $from 0 $end1]
if { $end1 != "abort" } {
set exists [lreplace $exists 0 0]
set noexist [lreplace $noexist 0 0 $from]
}
}
open_create -
open -
truncate {
set from [lindex $exists 0]
set op1ret [list $op1 $from 0 $end1]
if { $end1 != "abort" } {
set exists [lreplace $exists 0 0]
set open [list $from]
}
set noexist [lreplace $noexist 0 0]
}
open_excl {
set from [lindex $noexist 0]
set op1ret [list $op1 $from 0 $end1]
if { $end1 != "abort" } {
set noexist [lreplace $noexist 0 0]
set open [list $from]
}
set exists [lreplace $exists 0 0]
}
}
set op2list [create_op2 $op2 $exists $noexist $open $retval]
foreach o $op2list {
lappend retlist [list $op1ret $o]
}
return $retlist
}
proc create_badtests { op1 op2 exists noexist open retval {end1 ""} } {
set retlist {}
switch $op1 {
rename {
set from [lindex $exists 0]
set to [lindex $noexist 0]
set op1list1 \
[list $op1 "$to $to" "no such file" $end1]
set op1list2 \
[list $op1 "$to $from" "no such file" $end1]
set op1list3 \
[list $op1 "$from $from" "file exists" $end1]
set op1list [list $op1list1 $op1list2 $op1list3]
set op2list [create_op2 \
$op2 $exists $noexist $open $retval]
foreach op1 $op1list {
foreach op2 $op2list {
lappend retlist [list $op1 $op2]
}
}
return $retlist
}
remove -
open -
truncate {
set file [lindex $noexist 0]
set op1list [list $op1 $file "no such file" $end1]
set op2list [create_op2 \
$op2 $exists $noexist $open $retval]
foreach op2 $op2list {
lappend retlist [list $op1list $op2]
}
return $retlist
}
open_excl {
set file [lindex $exists 0]
set op1list [list $op1 $file "file exists" $end1]
set op2list [create_op2 \
$op2 $exists $noexist $open $retval]
foreach op2 $op2list {
lappend retlist [list $op1list $op2]
}
return $retlist
}
}
}
proc create_op2 { op2 exists noexist open retval } {
set retlist {}
switch $op2 {
rename {
if { $retval == 0 } {
set old $exists
set new $noexist
set retlist \
[build_retlist $op2 $old $new $retval]
}
if { $retval == "file exists" } {
set old $exists
set new $exists
set retlist \
[build_retlist $op2 $old $new $retval]
}
if { $retval == "no such file" } {
set old $noexist
set new $exists
set retlist1 \
[build_retlist $op2 $old $new $retval]
set old $noexist
set new $noexist
set retlist2 \
[build_retlist $op2 $old $new $retval]
set retlist [concat $retlist1 $retlist2]
}
}
remove {
if { $retval == 0 } {
set file $exists
}
if { $retval == "file exists" } {
return
}
if { $retval == "no such file" } {
set file $noexist
}
set retlist [build_retlist $op2 $file "" $retval]
}
open_create {
if { $retval == 0 } {
set file [concat $exists $open $noexist]
}
if { $retval == "file exists" || \
$retval == "no such file" } {
return
}
set retlist [build_retlist $op2 $file "" $retval]
}
open {
if { $retval == 0 } {
set file [concat $exists $open]
}
if { $retval == "no such file" } {
set file $noexist
}
if { $retval == "file exists" } {
return
}
set retlist [build_retlist $op2 $file "" $retval]
}
open_excl {
if { $retval == 0 } {
set file $noexist
}
if { $retval == "file exists" } {
set file [concat $exists $open]
}
if { $retval == "no such file" } {
return
}
set retlist [build_retlist $op2 $file "" $retval]
}
truncate {
if { $retval == 0 } {
set file $exists
}
if { $retval == "no such file" || \
$retval == "file exists" } {
return
}
set retlist [build_retlist $op2 $file "" $retval]
}
}
return $retlist
}
proc build_retlist { op2 file1 file2 retval } {
set retlist {}
if { $file2 == "" } {
foreach f1 $file1 {
lappend retlist [list $op2 $f1 $retval]
}
} else {
foreach f1 $file1 {
foreach f2 $file2 {
lappend retlist [list $op2 "$f1 $f2" $retval]
}
}
}
return $retlist
}
proc extract_error { message } {
if { [is_substr $message "exists"] == 1 } {
set message "file exists"
} elseif {[is_substr $message "no such file"] == 1 } {
set message "no such file"
}
return $message
}