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