1# Commands covered:  uplevel
2#
3# This file contains a collection of tests for one or more of the Tcl built-in
4# commands.  Sourcing this file into Tcl runs the tests and generates output
5# for errors.  No output means no errors were found.
6#
7# Copyright © 1991-1993 The Regents of the University of California.
8# Copyright © 1994 Sun Microsystems, Inc.
9# Copyright © 1998-1999 Scriptics Corporation.
10#
11# See the file "license.terms" for information on usage and redistribution of
12# this file, and for a DISCLAIMER OF ALL WARRANTIES.
13
14if {"::tcltest" ni [namespace children]} {
15    package require tcltest 2.5
16    namespace import -force ::tcltest::*
17}
18
19proc a {x y} {
20    newset z [expr {$x + $y}]
21    return $z
22}
23proc newset {name value} {
24    uplevel set $name $value
25    uplevel 1 {uplevel 1 {set xyz 22}}
26}
27
28test uplevel-1.1 {simple operation} {
29    set xyz 0
30    a 22 33
31} 55
32test uplevel-1.2 {command is another uplevel command} {
33    set xyz 0
34    a 22 33
35    set xyz
36} 22
37
38proc a1 {} {
39    b1
40    global a a1
41    set a $x
42    set a1 $y
43}
44proc b1 {} {
45    c1
46    global b b1
47    set b $x
48    set b1 $y
49}
50proc c1 {} {
51    uplevel 1 set x 111
52    uplevel #2 set y 222
53    uplevel 2 set x 333
54    uplevel #1 set y 444
55    uplevel 3 set x 555
56    uplevel #0 set y 666
57}
58a1
59test uplevel-2.1 {relative and absolute uplevel} {set a} 333
60test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
61test uplevel-2.3 {relative and absolute uplevel} {set b} 111
62test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
63test uplevel-2.5 {relative and absolute uplevel} {set x} 555
64test uplevel-2.6 {relative and absolute uplevel} {set y} 666
65
66test uplevel-3.1 {uplevel to same level} {
67    set x 33
68    uplevel #0 set x 44
69    set x
70} 44
71test uplevel-3.2 {uplevel to same level} {
72    set x 33
73    uplevel 0 set x
74} 33
75test uplevel-3.3 {uplevel to same level} {
76    set y xxx
77    proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
78    a1
79} 66
80test uplevel-3.4 {uplevel to same level} {
81    set y zzz
82    proc a1 {} {set y 55; uplevel #1 set y}
83    a1
84} 55
85
86test uplevel-4.0.1 {error: non-existent level} -body {
87    uplevel #0 { uplevel { set y 222 } }
88} -returnCodes error -result {bad level "1"}
89test uplevel-4.0.2 {error: non-existent level} -setup {
90    interp create i
91} -body {
92    i eval { uplevel { set y 222 } }
93} -returnCodes error -result {bad level "1"} -cleanup {
94    interp delete i
95}
96test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
97    apply {{} {
98	uplevel #2 {set y 222}
99    }}
100} -result {bad level "#2"}
101test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
102    apply {{} {
103	uplevel 3 {set a b}
104    }}
105} -result {bad level "3"}
106test uplevel-4.3 {error: not enough args} -returnCodes error -body {
107    uplevel
108} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"}
109test uplevel-4.4 {error: not enough args} -returnCodes error -body {
110    apply {{} {
111	uplevel 1
112    }}
113} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"}
114test uplevel-4.5 {level parsing} {
115    apply {{} {uplevel 0 {}}}
116} {}
117test uplevel-4.6 {level parsing} {
118    apply {{} {uplevel #0 {}}}
119} {}
120test uplevel-4.7 {level parsing} {
121    apply {{} {uplevel [expr 0] {}}}
122} {}
123test uplevel-4.8 {level parsing} {
124    apply {{} {uplevel #[expr 0] {}}}
125} {}
126test uplevel-4.9 {level parsing} {
127    apply {{} {uplevel -0 {}}}
128} {}
129test uplevel-4.10 {level parsing} {
130    apply {{} {uplevel #-0 {}}}
131} {}
132test uplevel-4.11 {level parsing} {
133    apply {{} {uplevel [expr -0] {}}}
134} {}
135test uplevel-4.12 {level parsing} {
136    apply {{} {uplevel #[expr -0] {}}}
137} {}
138test uplevel-4.13 {level parsing} {
139    apply {{} {uplevel 1 {}}}
140} {}
141test uplevel-4.14 {level parsing} {
142    apply {{} {uplevel #1 {}}}
143} {}
144test uplevel-4.15 {level parsing} {
145    apply {{} {uplevel [expr 1] {}}}
146} {}
147test uplevel-4.16 {level parsing} {
148    apply {{} {uplevel #[expr 1] {}}}
149} {}
150test uplevel-4.17 {level parsing} -returnCodes error -body {
151    apply {{} {uplevel -0xffffffff {}}}
152} -result {bad level "-0xffffffff"}
153test uplevel-4.18 {level parsing} -returnCodes error -body {
154    apply {{} {uplevel #-0xffffffff {}}}
155} -result {bad level "#-0xffffffff"}
156test uplevel-4.19 {level parsing} -returnCodes error -body {
157    apply {{} {uplevel [expr -0xffffffff] {}}}
158} -result {bad level "-4294967295"}
159test uplevel-4.20 {level parsing} -returnCodes error -body {
160    apply {{} {uplevel #[expr -0xffffffff] {}}}
161} -result {bad level "#-4294967295"}
162test uplevel-4.21 {level parsing} -body {
163    apply {{} {uplevel -1 {}}}
164} -returnCodes error -result {bad level "-1"}
165test uplevel-4.22 {level parsing} -body {
166    apply {{} {uplevel #-1 {}}}
167} -returnCodes error -result {bad level "#-1"}
168test uplevel-4.23 {level parsing} -body {
169    apply {{} {uplevel [expr -1] {}}}
170} -returnCodes error -result {bad level "-1"}
171test uplevel-4.24 {level parsing} -body {
172    apply {{} {uplevel #[expr -1] {}}}
173} -returnCodes error -result {bad level "#-1"}
174test uplevel-4.25 {level parsing} -body {
175    apply {{} {uplevel 0xffffffff {}}}
176} -returnCodes error -result {bad level "0xffffffff"}
177test uplevel-4.26 {level parsing} -body {
178    apply {{} {uplevel #0xffffffff {}}}
179} -returnCodes error -result {bad level "#0xffffffff"}
180test uplevel-4.27 {level parsing} -body {
181    apply {{} {uplevel [expr 0xffffffff] {}}}
182} -returnCodes error -result {bad level "4294967295"}
183test uplevel-4.28 {level parsing} -body {
184    apply {{} {uplevel #[expr 0xffffffff] {}}}
185} -returnCodes error -result {bad level "#4294967295"}
186test uplevel-4.29 {level parsing} -body {
187    apply {{} {uplevel 0.2 {}}}
188} -returnCodes error -result {invalid command name "0.2"}
189test uplevel-4.30 {level parsing} -body {
190    apply {{} {uplevel #0.2 {}}}
191} -returnCodes error -result {bad level "#0.2"}
192test uplevel-4.31 {level parsing} -body {
193    apply {{} {uplevel [expr 0.2] {}}}
194} -returnCodes error -result {invalid command name "0.2"}
195test uplevel-4.32 {level parsing} -body {
196    apply {{} {uplevel #[expr 0.2] {}}}
197} -returnCodes error -result {bad level "#0.2"}
198test uplevel-4.33 {level parsing} -body {
199    apply {{} {uplevel .2 {}}}
200} -returnCodes error -result {invalid command name ".2"}
201test uplevel-4.34 {level parsing} -body {
202    apply {{} {uplevel #.2 {}}}
203} -returnCodes error -result {bad level "#.2"}
204test uplevel-4.35 {level parsing} -body {
205    apply {{} {uplevel [expr .2] {}}}
206} -returnCodes error -result {invalid command name "0.2"}
207test uplevel-4.36 {level parsing} -body {
208    apply {{} {uplevel #[expr .2] {}}}
209} -returnCodes error -result {bad level "#0.2"}
210
211
212
213
214proc a2 {} {
215    uplevel a3
216}
217proc a3 {} {
218    global x y
219    set x [info level]
220    set y [info level 1]
221}
222a2
223test uplevel-5.1 {info level} {set x} 1
224test uplevel-5.2 {info level} {set y} a3
225
226namespace eval ns1 {
227    proc set args {return ::ns1}
228}
229proc a2 {} {
230    uplevel {set x ::}
231}
232test uplevel-6.1 {uplevel and shadowed cmds} {
233    set res [namespace eval ns1 a2]
234    lappend res [namespace eval ns2 a2]
235    lappend res [namespace eval ns1 a2]
236    namespace eval ns1 {rename set {}}
237    lappend res [namespace eval ns1 a2]
238} {::ns1 :: ::ns1 ::}
239
240#
241# These tests verify that upleveled scripts run in the correct level and access
242# the proper variables.
243#
244
245test uplevel-7.1 {var access, no LVT in either level} -setup {
246    set x 1
247    unset -nocomplain y z
248} -body {
249    namespace eval foo {
250	set x 2
251	set y 2
252	uplevel 1 {
253	    set x 3
254	    set y 3
255	    set z 3
256	}
257    }
258    list $x $y $z
259} -cleanup {
260    namespace delete foo
261    unset -nocomplain x y z
262} -result {3 3 3}
263
264test uplevel-7.2 {var access, no LVT in upper level} -setup {
265    set x 1
266    unset -nocomplain y z
267} -body {
268    proc foo {} {
269	set x 2
270	set y 2
271	uplevel 1 {
272	    set x 3
273	    set y 3
274	    set z 3
275	}
276    }
277    foo
278    list $x $y $z
279} -cleanup {
280    rename foo {}
281    unset -nocomplain x y z
282} -result {3 3 3}
283
284test uplevel-7.3 {var access, LVT in upper level} -setup {
285    proc moo {} {
286	set x 1; #var in LVT
287	unset -nocomplain y z
288	foo
289	list $x $y $z
290    }
291} -body {
292    proc foo {} {
293	set x 2
294	set y 2
295	uplevel 1 {
296	    set x 3
297	    set y 3
298	    set z 3
299	}
300    }
301    foo
302    moo
303} -cleanup {
304    rename foo {}
305    rename moo {}
306} -result {3 3 3}
307
308
309test uplevel-8.0 {
310    string representation isn't generated when there is only one argument
311} -body {
312    set res {}
313    set script [list lindex 5]
314    lappend res [apply {script {
315	uplevel $script
316    }} $script]
317    lappend res [string match {value is a list *no string representation*} [
318	::tcl::unsupported::representation $script]]
319} -cleanup {
320    unset script
321    unset res
322} -result {5 1}
323
324
325# cleanup
326::tcltest::cleanupTests
327return
328
329# Local Variables:
330# mode: tcl
331# fill-column: 78
332# End:
333