1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 2003,2008 Oracle. All rights reserved. 4# 5# $Id: foputils.tcl,v 12.8 2008/01/08 20:58:53 bostic Exp $ 6# 7proc do_op {omethod op names txn env {largs ""}} { 8 switch -exact $op { 9 delete { do_delete $names } 10 rename { do_rename $names $txn $env } 11 remove { do_remove $names $txn $env } 12 noop { do_noop } 13 open_create { do_create $omethod $names $txn $env $largs } 14 open { do_open $omethod $names $txn $env $largs } 15 open_excl { do_create_excl $omethod $names $txn $env $largs } 16 truncate { do_truncate $omethod $names $txn $env $largs } 17 default { puts "FAIL: operation $op not recognized" } 18 } 19} 20 21proc do_subdb_op {omethod op names txn env {largs ""}} { 22 # 23 # The 'noop' and 'delete' actions are the same 24 # for subdbs as for regular db files. 25 # 26 switch -exact $op { 27 delete { do_delete $names } 28 rename { do_subdb_rename $names $txn $env } 29 remove { do_subdb_remove $names $txn $env } 30 noop { do_noop } 31 default { puts "FAIL: operation $op not recognized" } 32 } 33} 34 35proc do_inmem_op {omethod op names txn env {largs ""}} { 36 # 37 # The in-memory versions of do_op are different in 38 # that we don't need to pass in the filename, just 39 # the subdb names. 40 # 41 switch -exact $op { 42 delete { do_delete $names } 43 rename { do_inmem_rename $names $txn $env } 44 remove { do_inmem_remove $names $txn $env } 45 noop { do_noop } 46 open_create { do_inmem_create $omethod $names $txn $env $largs } 47 open { do_inmem_open $omethod $names $txn $env $largs } 48 open_excl { do_inmem_create_excl $omethod $names $txn $env $largs } 49 truncate { do_inmem_truncate $omethod $names $txn $env $largs } 50 default { puts "FAIL: operation $op not recognized" } 51 } 52} 53 54proc do_delete {names} { 55 # 56 # This is the odd man out among the ops -- it's not a Berkeley 57 # DB file operation, but mimics an operation done externally, 58 # as if a user deleted a file with "rm" or "erase". 59 # 60 # We assume the file is found in $testdir. 61 # 62 global testdir 63 64 if {[catch [fileremove -f $testdir/$names] result]} { 65 return $result 66 } else { 67 return 0 68 } 69} 70 71proc do_noop { } { 72 # Do nothing. Report success. 73 return 0 74} 75 76proc do_rename {names txn env} { 77 # Pull db names out of $names 78 set oldname [lindex $names 0] 79 set newname [lindex $names 1] 80 81 if {[catch {eval $env dbrename -txn $txn \ 82 $oldname $newname} result]} { 83 return $result 84 } else { 85 return 0 86 } 87} 88 89proc do_subdb_rename {names txn env} { 90 # Pull db and subdb names out of $names 91 set filename [lindex $names 0] 92 set oldsname [lindex $names 1] 93 set newsname [lindex $names 2] 94 95 if {[catch {eval $env dbrename -txn $txn $filename \ 96 $oldsname $newsname} result]} { 97 return $result 98 } else { 99 return 0 100 } 101} 102 103proc do_inmem_rename {names txn env} { 104 # Pull db and subdb names out of $names 105 set filename "" 106 set oldsname [lindex $names 0] 107 set newsname [lindex $names 1] 108 if {[catch {eval $env dbrename -txn $txn {$filename} \ 109 $oldsname $newsname} result]} { 110 return $result 111 } else { 112 return 0 113 } 114} 115 116 117proc do_remove {names txn env} { 118 if {[catch {eval $env dbremove -txn $txn $names} result]} { 119 return $result 120 } else { 121 return 0 122 } 123} 124 125proc do_subdb_remove {names txn env} { 126 set filename [lindex $names 0] 127 set subname [lindex $names 1] 128 if {[catch {eval $env dbremove -txn $txn $filename $subname} result]} { 129 return $result 130 } else { 131 return 0 132 } 133} 134 135proc do_inmem_remove {names txn env} { 136 if {[catch {eval $env dbremove -txn $txn {""} $names} result]} { 137 return $result 138 } else { 139 return 0 140 } 141} 142 143proc do_create {omethod names txn env {largs ""}} { 144 if {[catch {eval berkdb_open -create $omethod $largs -env $env \ 145 -txn $txn $names} result]} { 146 return $result 147 } else { 148 return 0 149 } 150} 151 152proc do_inmem_create {omethod names txn env {largs ""}} { 153 if {[catch {eval berkdb_open -create $omethod $largs -env $env \ 154 -txn $txn "" $names} result]} { 155 return $result 156 } else { 157 return 0 158 } 159} 160 161proc do_open {omethod names txn env {largs ""}} { 162 if {[catch {eval berkdb_open $omethod $largs -env $env \ 163 -txn $txn $names} result]} { 164 return $result 165 } else { 166 return 0 167 } 168} 169 170proc do_inmem_open {omethod names txn env {largs ""}} { 171 if {[catch {eval berkdb_open $omethod $largs -env $env \ 172 -txn $txn {""} $names} result]} { 173 return $result 174 } else { 175 return 0 176 } 177} 178 179proc do_create_excl {omethod names txn env {largs ""}} { 180 if {[catch {eval berkdb_open -create -excl $omethod $largs -env $env \ 181 -txn $txn $names} result]} { 182 return $result 183 } else { 184 return 0 185 } 186} 187 188proc do_inmem_create_excl {omethod names txn env {largs ""}} { 189 if {[catch {eval berkdb_open -create -excl $omethod $largs -env $env \ 190 -txn $txn {""} $names} result]} { 191 return $result 192 } else { 193 return 0 194 } 195} 196 197proc do_truncate {omethod names txn env {largs ""}} { 198 # First we have to get a handle. We omit the -create flag 199 # because testing of truncate is meaningful only in cases 200 # where the database already exists. 201 set db [eval {berkdb_open $omethod} $largs {-env $env -txn $txn $names}] 202 error_check_good db_open [is_valid_db $db] TRUE 203 204 if {[catch {$db truncate -txn $txn} result]} { 205 return $result 206 } else { 207 return 0 208 } 209} 210 211proc do_inmem_truncate {omethod names txn env {largs ""}} { 212 set db [eval {berkdb_open $omethod} $largs {-env $env -txn $txn "" $names}] 213 error_check_good db_open [is_valid_db $db] TRUE 214 215 if {[catch {$db truncate -txn $txn} result]} { 216 return $result 217 } else { 218 return 0 219 } 220} 221 222proc create_tests { op1 op2 exists noexist open retval { end1 "" } } { 223 set retlist {} 224 switch $op1 { 225 rename { 226 # Use first element from exists list 227 set from [lindex $exists 0] 228 # Use first element from noexist list 229 set to [lindex $noexist 0] 230 231 # This is the first operation, which should succeed 232 set op1ret [list $op1 "$from $to" 0 $end1] 233 234 # Adjust 'exists' and 'noexist' list if and only if 235 # txn1 was not aborted. 236 if { $end1 != "abort" } { 237 set exists [lreplace $exists 0 0 $to] 238 set noexist [lreplace $noexist 0 0 $from] 239 } 240 } 241 remove { 242 set from [lindex $exists 0] 243 set op1ret [list $op1 $from 0 $end1] 244 245 if { $end1 != "abort" } { 246 set exists [lreplace $exists 0 0] 247 set noexist [lreplace $noexist 0 0 $from] 248 } 249 } 250 open_create - 251 open - 252 truncate { 253 set from [lindex $exists 0] 254 set op1ret [list $op1 $from 0 $end1] 255 256 if { $end1 != "abort" } { 257 set exists [lreplace $exists 0 0] 258 set open [list $from] 259 } 260 261 # Eliminate the 1st element in noexist: it is 262 # equivalent to the 2nd element (neither ever exists). 263 set noexist [lreplace $noexist 0 0] 264 } 265 open_excl { 266 # Use first element from noexist list 267 set from [lindex $noexist 0] 268 set op1ret [list $op1 $from 0 $end1] 269 270 if { $end1 != "abort" } { 271 set noexist [lreplace $noexist 0 0] 272 set open [list $from] 273 } 274 275 # Eliminate the 1st element in exists: it is 276 # equivalent to the 2nd element (both already exist). 277 set exists [lreplace $exists 0 0] 278 } 279 } 280 281 # Generate possible second operations given the return value. 282 set op2list [create_op2 $op2 $exists $noexist $open $retval] 283 284 foreach o $op2list { 285 lappend retlist [list $op1ret $o] 286 } 287 return $retlist 288} 289 290proc create_badtests { op1 op2 exists noexist open retval {end1 ""} } { 291 set retlist {} 292 switch $op1 { 293 rename { 294 # Use first element from exists list 295 set from [lindex $exists 0] 296 # Use first element from noexist list 297 set to [lindex $noexist 0] 298 299 # This is the first operation, which should fail 300 set op1list1 \ 301 [list $op1 "$to $to" "no such file" $end1] 302 set op1list2 \ 303 [list $op1 "$to $from" "no such file" $end1] 304 set op1list3 \ 305 [list $op1 "$from $from" "file exists" $end1] 306 set op1list [list $op1list1 $op1list2 $op1list3] 307 308 # Generate second operations given the return value. 309 set op2list [create_op2 \ 310 $op2 $exists $noexist $open $retval] 311 foreach op1 $op1list { 312 foreach op2 $op2list { 313 lappend retlist [list $op1 $op2] 314 } 315 } 316 return $retlist 317 } 318 remove - 319 open - 320 truncate { 321 set file [lindex $noexist 0] 322 set op1list [list $op1 $file "no such file" $end1] 323 324 set op2list [create_op2 \ 325 $op2 $exists $noexist $open $retval] 326 foreach op2 $op2list { 327 lappend retlist [list $op1list $op2] 328 } 329 return $retlist 330 } 331 open_excl { 332 set file [lindex $exists 0] 333 set op1list [list $op1 $file "file exists" $end1] 334 set op2list [create_op2 \ 335 $op2 $exists $noexist $open $retval] 336 foreach op2 $op2list { 337 lappend retlist [list $op1list $op2] 338 } 339 return $retlist 340 } 341 } 342} 343 344proc create_op2 { op2 exists noexist open retval } { 345 set retlist {} 346 switch $op2 { 347 rename { 348 # Successful renames arise from renaming existing 349 # to non-existing files. 350 if { $retval == 0 } { 351 set old $exists 352 set new $noexist 353 set retlist \ 354 [build_retlist $op2 $old $new $retval] 355 } 356 # "File exists" errors arise from renaming existing 357 # to existing files. 358 if { $retval == "file exists" } { 359 set old $exists 360 set new $exists 361 set retlist \ 362 [build_retlist $op2 $old $new $retval] 363 } 364 # "No such file" errors arise from renaming files 365 # that don't exist. 366 if { $retval == "no such file" } { 367 set old $noexist 368 set new $exists 369 set retlist1 \ 370 [build_retlist $op2 $old $new $retval] 371 372 set old $noexist 373 set new $noexist 374 set retlist2 \ 375 [build_retlist $op2 $old $new $retval] 376 377 set retlist [concat $retlist1 $retlist2] 378 } 379 } 380 remove { 381 # Successful removes result from removing existing 382 # files. 383 if { $retval == 0 } { 384 set file $exists 385 } 386 # "File exists" does not happen in remove. 387 if { $retval == "file exists" } { 388 return 389 } 390 # "No such file" errors arise from trying to remove 391 # files that don't exist. 392 if { $retval == "no such file" } { 393 set file $noexist 394 } 395 set retlist [build_retlist $op2 $file "" $retval] 396 } 397 open_create { 398 # Open_create should be successful with existing, 399 # open, or non-existing files. 400 if { $retval == 0 } { 401 set file [concat $exists $open $noexist] 402 } 403 # "File exists" and "no such file" 404 # do not happen in open_create. 405 if { $retval == "file exists" || \ 406 $retval == "no such file" } { 407 return 408 } 409 set retlist [build_retlist $op2 $file "" $retval] 410 } 411 open { 412 # Open should be successful with existing or open files. 413 if { $retval == 0 } { 414 set file [concat $exists $open] 415 } 416 # "No such file" errors arise from trying to open 417 # non-existent files. 418 if { $retval == "no such file" } { 419 set file $noexist 420 } 421 # "File exists" errors do not happen in open. 422 if { $retval == "file exists" } { 423 return 424 } 425 set retlist [build_retlist $op2 $file "" $retval] 426 } 427 open_excl { 428 # Open_excl should be successful with non-existent files. 429 if { $retval == 0 } { 430 set file $noexist 431 } 432 # "File exists" errors arise from trying to open 433 # existing files. 434 if { $retval == "file exists" } { 435 set file [concat $exists $open] 436 } 437 # "No such file" errors do not arise in open_excl. 438 if { $retval == "no such file" } { 439 return 440 } 441 set retlist [build_retlist $op2 $file "" $retval] 442 } 443 truncate { 444 # Truncate should be successful with existing files. 445 if { $retval == 0 } { 446 set file $exists 447 } 448 # No other return values are meaningful to test since 449 # do_truncate starts with an open and we've already 450 # tested open. 451 if { $retval == "no such file" || \ 452 $retval == "file exists" } { 453 return 454 } 455 set retlist [build_retlist $op2 $file "" $retval] 456 } 457 } 458 return $retlist 459} 460 461proc build_retlist { op2 file1 file2 retval } { 462 set retlist {} 463 if { $file2 == "" } { 464 foreach f1 $file1 { 465 lappend retlist [list $op2 $f1 $retval] 466 } 467 } else { 468 foreach f1 $file1 { 469 foreach f2 $file2 { 470 lappend retlist [list $op2 "$f1 $f2" $retval] 471 } 472 } 473 } 474 return $retlist 475} 476 477proc extract_error { message } { 478 if { [is_substr $message "exists"] == 1 } { 479 set message "file exists" 480 } elseif {[is_substr $message "no such file"] == 1 } { 481 set message "no such file" 482 } 483 return $message 484} 485