1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: ddoyscript.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# Deadlock detector script tester. 8# Usage: ddoyscript dir lockerid numprocs 9# dir: DBHOME directory 10# lockerid: Lock id for this locker 11# numprocs: Total number of processes running 12# myid: id of this process -- 13# the order that the processes are created is the same 14# in which their lockerid's were allocated so we know 15# that there is a locker age relationship that is isomorphic 16# with the order releationship of myid's. 17 18source ./include.tcl 19source $test_path/test.tcl 20source $test_path/testutils.tcl 21 22set usage "ddoyscript dir lockerid numprocs oldoryoung" 23 24# Verify usage 25if { $argc != 5 } { 26 puts stderr "FAIL:[timestamp] Usage: $usage" 27 exit 28} 29 30# Initialize arguments 31set dir [lindex $argv 0] 32set lockerid [ lindex $argv 1 ] 33set numprocs [ lindex $argv 2 ] 34set old_or_young [lindex $argv 3] 35set myid [lindex $argv 4] 36 37set myenv [berkdb_env -lock -home $dir -create -mode 0644] 38error_check_bad lock_open $myenv NULL 39error_check_good lock_open [is_substr $myenv "env"] 1 40 41# There are two cases here -- oldest/youngest or a ring locker. 42 43if { $myid == 0 || $myid == [expr $numprocs - 1] } { 44 set waitobj NULL 45 set ret 0 46 47 if { $myid == 0 } { 48 set objid 2 49 if { $old_or_young == "o" } { 50 set waitobj [expr $numprocs - 1] 51 } 52 } else { 53 if { $old_or_young == "y" } { 54 set waitobj 0 55 } 56 set objid 4 57 } 58 59 # Acquire own read lock 60 if {[catch {$myenv lock_get read $lockerid $myid} selflock] != 0} { 61 puts $errorInfo 62 } else { 63 error_check_good selfget:$objid [is_substr $selflock $myenv] 1 64 } 65 66 # Acquire read lock 67 if {[catch {$myenv lock_get read $lockerid $objid} lock1] != 0} { 68 puts $errorInfo 69 } else { 70 error_check_good lockget:$objid [is_substr $lock1 $myenv] 1 71 } 72 73 tclsleep 10 74 75 if { $waitobj == "NULL" } { 76 # Sleep for a good long while 77 tclsleep 90 78 } else { 79 # Acquire write lock 80 if {[catch {$myenv lock_get write $lockerid $waitobj} lock2] 81 != 0} { 82 puts $errorInfo 83 set ret ERROR 84 } else { 85 error_check_good lockget:$waitobj \ 86 [is_substr $lock2 $myenv] 1 87 88 # Now release it 89 if {[catch {$lock2 put} err] != 0} { 90 puts $errorInfo 91 set ret ERROR 92 } else { 93 error_check_good lockput:oy:$objid $err 0 94 } 95 } 96 97 } 98 99 # Release self lock 100 if {[catch {$selflock put} err] != 0} { 101 puts $errorInfo 102 if { $ret == 0 } { 103 set ret ERROR 104 } 105 } else { 106 error_check_good selfput:oy:$myid $err 0 107 if { $ret == 0 } { 108 set ret 1 109 } 110 } 111 112 # Release first lock 113 if {[catch {$lock1 put} err] != 0} { 114 puts $errorInfo 115 if { $ret == 0 } { 116 set ret ERROR 117 } 118 } else { 119 error_check_good lockput:oy:$objid $err 0 120 if { $ret == 0 } { 121 set ret 1 122 } 123 } 124 125} else { 126 # Make sure that we succeed if we're locking the same object as 127 # oldest or youngest. 128 if { [expr $myid % 2] == 0 } { 129 set mode read 130 } else { 131 set mode write 132 } 133 # Obtain first lock (should always succeed). 134 if {[catch {$myenv lock_get $mode $lockerid $myid} lock1] != 0} { 135 puts $errorInfo 136 } else { 137 error_check_good lockget:$myid [is_substr $lock1 $myenv] 1 138 } 139 140 tclsleep 30 141 142 set nextobj [expr $myid + 1] 143 if { $nextobj == [expr $numprocs - 1] } { 144 set nextobj 1 145 } 146 147 set ret 1 148 if {[catch {$myenv lock_get write $lockerid $nextobj} lock2] != 0} { 149 if {[string match "*DEADLOCK*" $lock2] == 1} { 150 set ret DEADLOCK 151 } else { 152 set ret ERROR 153 } 154 } else { 155 error_check_good lockget:$nextobj [is_substr $lock2 $myenv] 1 156 } 157 158 # Now release the first lock 159 error_check_good lockput:$lock1 [$lock1 put] 0 160 161 if {$ret == 1} { 162 error_check_bad lockget:$nextobj $lock2 NULL 163 error_check_good lockget:$nextobj [is_substr $lock2 $myenv] 1 164 error_check_good lockput:$lock2 [$lock2 put] 0 165 } 166} 167 168puts $ret 169error_check_good lock_id_free [$myenv lock_id_free $lockerid] 0 170error_check_good envclose [$myenv close] 0 171exit 172