mirror of
https://github.com/berkeleydb/libdb.git
synced 2024-09-29 03:36:55 +00:00
548 lines
14 KiB
Tcl
548 lines
14 KiB
Tcl
# See the file LICENSE for redistribution information.
|
|
#
|
|
# Copyright (c) 2003, 2011 Oracle and/or its affiliates. All rights reserved.
|
|
#
|
|
# $Id$
|
|
#
|
|
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 ""}} {
|
|
#
|
|
# The 'noop' and 'delete' actions are the same
|
|
# for subdbs as for regular db files.
|
|
#
|
|
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 ""}} {
|
|
#
|
|
# The in-memory versions of do_op are different in
|
|
# that we don't need to pass in the filename, just
|
|
# the subdb names.
|
|
#
|
|
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} {
|
|
#
|
|
# This is the odd man out among the ops -- it's not a Berkeley
|
|
# DB file operation, but mimics an operation done externally,
|
|
# as if a user deleted a file with "rm" or "erase".
|
|
#
|
|
# We assume the file is found in $testdir.
|
|
#
|
|
global testdir
|
|
|
|
if {[catch [fileremove -f $testdir/$names] result]} {
|
|
return $result
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
proc do_noop { } {
|
|
# Do nothing. Report success.
|
|
return 0
|
|
}
|
|
|
|
proc do_rename {names txn env} {
|
|
# Pull db names out of $names
|
|
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} {
|
|
# Pull db and subdb names out of $names
|
|
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} {
|
|
# Pull db and subdb names out of $names
|
|
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 ""}} {
|
|
# First we have to get a handle. We omit the -create flag
|
|
# because testing of truncate is meaningful only in cases
|
|
# where the database already exists.
|
|
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 {}
|
|
set redundant {}
|
|
switch $op1 {
|
|
rename {
|
|
# Use first element from exists list
|
|
set from [lindex $exists 0]
|
|
# Use first element from noexist list
|
|
set to [lindex $noexist 0]
|
|
|
|
# This is the first operation, which should succeed
|
|
set op1ret [list $op1 "$from $to" 0 $end1]
|
|
|
|
# Adjust 'exists' and 'noexist' list if txn was
|
|
# not aborted.
|
|
if { $end1 != "abort" } {
|
|
set exists [lreplace $exists 0 0 $to]
|
|
set noexist [lreplace $noexist 0 0 $from]
|
|
} else {
|
|
# Eliminate the 2nd element in noexist: it is
|
|
# equivalent to the 1st (neither ever exists).
|
|
set noexist [lreplace $noexist 1 1]
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
}
|
|
}
|
|
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]
|
|
} else {
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
set noexist [lreplace $noexist 1 1]
|
|
}
|
|
}
|
|
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]
|
|
} else {
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
}
|
|
|
|
# Eliminate the 2nd element in noexist: it is
|
|
# equivalent to the 1st (neither ever exists).
|
|
set noexist [lreplace $noexist 1 1]
|
|
}
|
|
open_excl {
|
|
# Use first element from noexist list
|
|
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]
|
|
} else {
|
|
set noexist [lreplace $noexist 1 1]
|
|
}
|
|
# It would be redundant to test both elements
|
|
# on the 'exists' list, but we do have to
|
|
# keep track of both.
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
}
|
|
}
|
|
|
|
# Generate possible second operations given the return value.
|
|
set op2list [create_op2 $op2 $exists $noexist $open $redundant $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 {
|
|
# Use first element from exists list
|
|
set from [lindex $exists 0]
|
|
# Use first element from noexist list
|
|
set to [lindex $noexist 0]
|
|
|
|
# This is the first operation, which should fail
|
|
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]
|
|
|
|
# Since the op failed, trim the 'exists' and 'noexist'
|
|
# lists to a single case each. It is redundant
|
|
# to test both elements on the 'exists' list, but
|
|
# keep track of the fact that both still exist.
|
|
set noexist [lreplace $noexist 1 1]
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
|
|
# Generate second operations given the return value.
|
|
set op2list [create_op2 \
|
|
$op2 $exists $noexist $open $redundant $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 noexist [lreplace $noexist 1 1]
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
|
|
set op2list [create_op2 \
|
|
$op2 $exists $noexist $open $redundant $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 noexist [lreplace $noexist 1 1]
|
|
set redundant [lindex $exists 1]
|
|
set exists [lreplace $exists 1 1]
|
|
|
|
set op2list [create_op2 \
|
|
$op2 $exists $noexist $open $redundant $retval]
|
|
foreach op2 $op2list {
|
|
lappend retlist [list $op1list $op2]
|
|
}
|
|
return $retlist
|
|
}
|
|
}
|
|
}
|
|
|
|
proc create_op2 { op2 exists noexist open redundant retval } {
|
|
set retlist {}
|
|
set existing [concat $exists $open $redundant]
|
|
switch $op2 {
|
|
rename {
|
|
# Successful renames arise from renaming existing
|
|
# to non-existing files.
|
|
if { $retval == 0 } {
|
|
set old $exists
|
|
set new $noexist
|
|
set retlist \
|
|
[build_retlist $op2 $old $new $retval $existing]
|
|
}
|
|
# "File exists" errors arise from renaming existing
|
|
# to existing files.
|
|
if { $retval == "file exists" } {
|
|
set old $exists
|
|
set new $exists
|
|
set retlist \
|
|
[build_retlist $op2 $old $new $retval $existing]
|
|
}
|
|
# "No such file" errors arise from renaming files
|
|
# that don't exist.
|
|
if { $retval == "no such file" } {
|
|
set old $noexist
|
|
set new $exists
|
|
set retlist1 \
|
|
[build_retlist $op2 $old $new $retval $existing]
|
|
|
|
set old $noexist
|
|
set new $noexist
|
|
set retlist2 \
|
|
[build_retlist $op2 $old $new $retval $existing]
|
|
|
|
set retlist [concat $retlist1 $retlist2]
|
|
}
|
|
}
|
|
remove {
|
|
# Successful removes result from removing existing
|
|
# files.
|
|
if { $retval == 0 } {
|
|
set file $exists
|
|
}
|
|
# "File exists" does not happen in remove.
|
|
if { $retval == "file exists" } {
|
|
return
|
|
}
|
|
# "No such file" errors arise from trying to remove
|
|
# files that don't exist.
|
|
if { $retval == "no such file" } {
|
|
set file $noexist
|
|
}
|
|
set retlist [build_retlist $op2 $file "" $retval $existing]
|
|
}
|
|
open_create {
|
|
# Open_create should be successful with existing,
|
|
# open, or non-existing files.
|
|
if { $retval == 0 } {
|
|
set file [concat $exists $open $noexist]
|
|
}
|
|
# "File exists" and "no such file"
|
|
# do not happen in open_create.
|
|
if { $retval == "file exists" || \
|
|
$retval == "no such file" } {
|
|
return
|
|
}
|
|
set retlist [build_retlist $op2 $file "" $retval $existing]
|
|
}
|
|
open {
|
|
# Open should be successful with existing or open files.
|
|
if { $retval == 0 } {
|
|
set file [concat $exists $open]
|
|
}
|
|
# "No such file" errors arise from trying to open
|
|
# non-existent files.
|
|
if { $retval == "no such file" } {
|
|
set file $noexist
|
|
}
|
|
# "File exists" errors do not happen in open.
|
|
if { $retval == "file exists" } {
|
|
return
|
|
}
|
|
set retlist [build_retlist $op2 $file "" $retval $existing]
|
|
}
|
|
open_excl {
|
|
# Open_excl should be successful with non-existent files.
|
|
if { $retval == 0 } {
|
|
set file $noexist
|
|
}
|
|
# "File exists" errors arise from trying to open
|
|
# existing files.
|
|
if { $retval == "file exists" } {
|
|
set file [concat $exists $open]
|
|
}
|
|
# "No such file" errors do not arise in open_excl.
|
|
if { $retval == "no such file" } {
|
|
return
|
|
}
|
|
set retlist [build_retlist $op2 $file "" $retval $existing]
|
|
}
|
|
truncate {
|
|
# Truncate should be successful with existing files.
|
|
if { $retval == 0 } {
|
|
set file $exists
|
|
}
|
|
# No other return values are meaningful to test since
|
|
# do_truncate starts with an open and we've already
|
|
# tested open.
|
|
if { $retval == "no such file" || \
|
|
$retval == "file exists" } {
|
|
return
|
|
}
|
|
set retlist [build_retlist $op2 $file "" $retval $existing]
|
|
}
|
|
}
|
|
return $retlist
|
|
}
|
|
|
|
proc build_retlist { op2 file1 file2 retval existing } {
|
|
set retlist {}
|
|
|
|
if { $file2 == "" } {
|
|
foreach f1 $file1 {
|
|
# If we're expecting a successful operation, we have
|
|
# adjust the list of files that remain after the op
|
|
# in certain cases.
|
|
set remaining $existing
|
|
if { $retval == 0 } {
|
|
switch $op2 {
|
|
remove {
|
|
set idx [lsearch -exact $remaining $f1]
|
|
set remaining \
|
|
[lreplace $remaining $idx $idx]
|
|
}
|
|
open_create -
|
|
open -
|
|
open_excl {
|
|
set idx [lsearch -exact $remaining $f1]
|
|
if { $idx == -1 } {
|
|
set remaining \
|
|
[lappend remaining $f1]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
lappend retlist [list $op2 $f1 $retval $remaining]
|
|
}
|
|
} else {
|
|
foreach f1 $file1 {
|
|
foreach f2 $file2 {
|
|
set remaining $existing
|
|
if { $op2 == "rename" && $retval == 0 } {
|
|
set idx [lsearch -exact $remaining $f1]
|
|
set remaining [lreplace $remaining $idx $idx]
|
|
set remaining [lappend remaining $f2]
|
|
}
|
|
lappend retlist [list $op2 "$f1 $f2" $retval $remaining]
|
|
}
|
|
}
|
|
}
|
|
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
|
|
}
|