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