os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/upvar.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/upvar.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,417 @@
1.4 +# Commands covered: upvar
1.5 +#
1.6 +# This file contains a collection of tests for one or more of the Tcl
1.7 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.8 +# generates output for errors. No output means no errors were found.
1.9 +#
1.10 +# Copyright (c) 1991-1993 The Regents of the University of California.
1.11 +# Copyright (c) 1994 Sun Microsystems, Inc.
1.12 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.13 +#
1.14 +# See the file "license.terms" for information on usage and redistribution
1.15 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 +#
1.17 +# RCS: @(#) $Id: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $
1.18 +
1.19 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.20 + package require tcltest
1.21 + namespace import -force ::tcltest::*
1.22 +}
1.23 +
1.24 +test upvar-1.1 {reading variables with upvar} {
1.25 + proc p1 {a b} {set c 22; set d 33; p2}
1.26 + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
1.27 + p1 foo bar
1.28 +} {foo bar 22 33 abc}
1.29 +test upvar-1.2 {reading variables with upvar} {
1.30 + proc p1 {a b} {set c 22; set d 33; p2}
1.31 + proc p2 {} {p3}
1.32 + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
1.33 + p1 foo bar
1.34 +} {foo bar 22 33 abc}
1.35 +test upvar-1.3 {reading variables with upvar} {
1.36 + proc p1 {a b} {set c 22; set d 33; p2}
1.37 + proc p2 {} {p3}
1.38 + proc p3 {} {
1.39 + upvar #1 a x1 b x2 c x3 d x4
1.40 + set a abc
1.41 + list $x1 $x2 $x3 $x4 $a
1.42 + }
1.43 + p1 foo bar
1.44 +} {foo bar 22 33 abc}
1.45 +test upvar-1.4 {reading variables with upvar} {
1.46 + set x1 44
1.47 + set x2 55
1.48 + proc p1 {} {p2}
1.49 + proc p2 {} {
1.50 + upvar 2 x1 x1 x2 a
1.51 + upvar #0 x1 b
1.52 + set c $b
1.53 + incr b 3
1.54 + list $x1 $a $b
1.55 + }
1.56 + p1
1.57 +} {47 55 47}
1.58 +test upvar-1.5 {reading array elements with upvar} {
1.59 + proc p1 {} {set a(0) zeroth; set a(1) first; p2}
1.60 + proc p2 {} {upvar a(0) x; set x}
1.61 + p1
1.62 +} {zeroth}
1.63 +
1.64 +test upvar-2.1 {writing variables with upvar} {
1.65 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
1.66 + proc p2 {} {
1.67 + upvar a x1 b x2 c x3 d x4
1.68 + set x1 14
1.69 + set x4 88
1.70 + }
1.71 + p1 foo bar
1.72 +} {14 bar 22 88}
1.73 +test upvar-2.2 {writing variables with upvar} {
1.74 + set x1 44
1.75 + set x2 55
1.76 + proc p1 {x1 x2} {
1.77 + upvar #0 x1 a
1.78 + upvar x2 b
1.79 + set a $x1
1.80 + set b $x2
1.81 + }
1.82 + p1 newbits morebits
1.83 + list $x1 $x2
1.84 +} {newbits morebits}
1.85 +test upvar-2.3 {writing variables with upvar} {
1.86 + catch {unset x1}
1.87 + catch {unset x2}
1.88 + proc p1 {x1 x2} {
1.89 + upvar #0 x1 a
1.90 + upvar x2 b
1.91 + set a $x1
1.92 + set b $x2
1.93 + }
1.94 + p1 newbits morebits
1.95 + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg
1.96 +} {0 newbits 0 morebits}
1.97 +test upvar-2.4 {writing array elements with upvar} {
1.98 + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)}
1.99 + proc p2 {} {upvar a(0) x; set x xyzzy}
1.100 + p1
1.101 +} {xyzzy xyzzy}
1.102 +
1.103 +test upvar-3.1 {unsetting variables with upvar} {
1.104 + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
1.105 + proc p2 {} {
1.106 + upvar 1 a x1 d x2
1.107 + unset x1 x2
1.108 + }
1.109 + p1 foo bar
1.110 +} {b c}
1.111 +test upvar-3.2 {unsetting variables with upvar} {
1.112 + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
1.113 + proc p2 {} {
1.114 + upvar 1 a x1 d x2
1.115 + unset x1 x2
1.116 + set x2 28
1.117 + }
1.118 + p1 foo bar
1.119 +} {b c d}
1.120 +test upvar-3.3 {unsetting variables with upvar} {
1.121 + set x1 44
1.122 + set x2 55
1.123 + proc p1 {} {p2}
1.124 + proc p2 {} {
1.125 + upvar 2 x1 a
1.126 + upvar #0 x2 b
1.127 + unset a b
1.128 + }
1.129 + p1
1.130 + list [info exists x1] [info exists x2]
1.131 +} {0 0}
1.132 +test upvar-3.4 {unsetting variables with upvar} {
1.133 + set x1 44
1.134 + set x2 55
1.135 + proc p1 {} {
1.136 + upvar x1 a x2 b
1.137 + unset a b
1.138 + set b 118
1.139 + }
1.140 + p1
1.141 + list [info exists x1] [catch {set x2} msg] $msg
1.142 +} {0 0 118}
1.143 +test upvar-3.5 {unsetting array elements with upvar} {
1.144 + proc p1 {} {
1.145 + set a(0) zeroth
1.146 + set a(1) first
1.147 + set a(2) second
1.148 + p2
1.149 + array names a
1.150 + }
1.151 + proc p2 {} {upvar a(0) x; unset x}
1.152 + p1
1.153 +} {1 2}
1.154 +test upvar-3.6 {unsetting then resetting array elements with upvar} {
1.155 + proc p1 {} {
1.156 + set a(0) zeroth
1.157 + set a(1) first
1.158 + set a(2) second
1.159 + p2
1.160 + list [array names a] [catch {set a(0)} msg] $msg
1.161 + }
1.162 + proc p2 {} {upvar a(0) x; unset x; set x 12345}
1.163 + p1
1.164 +} {{0 1 2} 0 12345}
1.165 +
1.166 +test upvar-4.1 {nested upvars} {
1.167 + set x1 88
1.168 + proc p1 {a b} {set c 22; set d 33; p2}
1.169 + proc p2 {} {global x1; upvar c x2; p3}
1.170 + proc p3 {} {
1.171 + upvar x1 a x2 b
1.172 + list $a $b
1.173 + }
1.174 + p1 14 15
1.175 +} {88 22}
1.176 +test upvar-4.2 {nested upvars} {
1.177 + set x1 88
1.178 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
1.179 + proc p2 {} {global x1; upvar c x2; p3}
1.180 + proc p3 {} {
1.181 + upvar x1 a x2 b
1.182 + set a foo
1.183 + set b bar
1.184 + }
1.185 + list [p1 14 15] $x1
1.186 +} {{14 15 bar 33} foo}
1.187 +
1.188 +proc tproc {args} {global x; set x [list $args [uplevel info vars]]}
1.189 +test upvar-5.1 {traces involving upvars} {
1.190 + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
1.191 + proc p2 {} {upvar c x1; set x1 22}
1.192 + set x ---
1.193 + p1 foo bar
1.194 + set x
1.195 +} {{x1 {} w} x1}
1.196 +test upvar-5.2 {traces involving upvars} {
1.197 + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
1.198 + proc p2 {} {upvar c x1; set x1}
1.199 + set x ---
1.200 + p1 foo bar
1.201 + set x
1.202 +} {{x1 {} r} x1}
1.203 +test upvar-5.3 {traces involving upvars} {
1.204 + proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2}
1.205 + proc p2 {} {upvar c x1; unset x1}
1.206 + set x ---
1.207 + p1 foo bar
1.208 + set x
1.209 +} {{x1 {} u} x1}
1.210 +
1.211 +test upvar-6.1 {retargeting an upvar} {
1.212 + proc p1 {} {
1.213 + set a(0) zeroth
1.214 + set a(1) first
1.215 + set a(2) second
1.216 + p2
1.217 + }
1.218 + proc p2 {} {
1.219 + upvar a x
1.220 + set result {}
1.221 + foreach i [array names x] {
1.222 + upvar a($i) x
1.223 + lappend result $x
1.224 + }
1.225 + lsort $result
1.226 + }
1.227 + p1
1.228 +} {first second zeroth}
1.229 +test upvar-6.2 {retargeting an upvar} {
1.230 + set x 44
1.231 + set y abcde
1.232 + proc p1 {} {
1.233 + global x
1.234 + set result $x
1.235 + upvar y x
1.236 + lappend result $x
1.237 + }
1.238 + p1
1.239 +} {44 abcde}
1.240 +test upvar-6.3 {retargeting an upvar} {
1.241 + set x 44
1.242 + set y abcde
1.243 + proc p1 {} {
1.244 + upvar y x
1.245 + lappend result $x
1.246 + global x
1.247 + lappend result $x
1.248 + }
1.249 + p1
1.250 +} {abcde 44}
1.251 +
1.252 +test upvar-7.1 {upvar to same level} {
1.253 + set x 44
1.254 + set y 55
1.255 + catch {unset uv}
1.256 + upvar #0 x uv
1.257 + set uv abc
1.258 + upvar 0 y uv
1.259 + set uv xyzzy
1.260 + list $x $y
1.261 +} {abc xyzzy}
1.262 +test upvar-7.2 {upvar to same level} {
1.263 + set x 1234
1.264 + set y 4567
1.265 + proc p1 {x y} {
1.266 + upvar 0 x uv
1.267 + set uv $y
1.268 + return "$x $y"
1.269 + }
1.270 + p1 44 89
1.271 +} {89 89}
1.272 +test upvar-7.3 {upvar to same level} {
1.273 + set x 1234
1.274 + set y 4567
1.275 + proc p1 {x y} {
1.276 + upvar #1 x uv
1.277 + set uv $y
1.278 + return "$x $y"
1.279 + }
1.280 + p1 xyz abc
1.281 +} {abc abc}
1.282 +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} {
1.283 + proc tt {} {upvar #1 toto loc; return $loc}
1.284 + list [catch tt msg] $msg
1.285 +} {1 {can't read "loc": no such variable}}
1.286 +test upvar-7.5 {potential memory leak when deleting variable table} {
1.287 + proc leak {} {
1.288 + array set foo {1 2 3 4}
1.289 + upvar 0 foo(1) bar
1.290 + }
1.291 + leak
1.292 +} {}
1.293 +
1.294 +test upvar-8.1 {errors in upvar command} {
1.295 + list [catch upvar msg] $msg
1.296 +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
1.297 +test upvar-8.2 {errors in upvar command} {
1.298 + list [catch {upvar 1} msg] $msg
1.299 +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
1.300 +test upvar-8.3 {errors in upvar command} {
1.301 + proc p1 {} {upvar a b c}
1.302 + list [catch p1 msg] $msg
1.303 +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
1.304 +test upvar-8.4 {errors in upvar command} {
1.305 + proc p1 {} {upvar 0 b b}
1.306 + list [catch p1 msg] $msg
1.307 +} {1 {can't upvar from variable to itself}}
1.308 +test upvar-8.5 {errors in upvar command} {
1.309 + proc p1 {} {upvar 0 a b; upvar 0 b a}
1.310 + list [catch p1 msg] $msg
1.311 +} {1 {can't upvar from variable to itself}}
1.312 +test upvar-8.6 {errors in upvar command} {
1.313 + proc p1 {} {set a 33; upvar b a}
1.314 + list [catch p1 msg] $msg
1.315 +} {1 {variable "a" already exists}}
1.316 +test upvar-8.7 {errors in upvar command} {
1.317 + proc p1 {} {trace variable a w foo; upvar b a}
1.318 + list [catch p1 msg] $msg
1.319 +} {1 {variable "a" has traces: can't use for upvar}}
1.320 +test upvar-8.8 {create nested array with upvar} {
1.321 + proc p1 {} {upvar x(a) b; set b(2) 44}
1.322 + catch {unset x}
1.323 + list [catch p1 msg] $msg
1.324 +} {1 {can't set "b(2)": variable isn't array}}
1.325 +test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} {
1.326 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.327 + catch {rename MakeLink ""}
1.328 + namespace eval ::test_ns_1 {}
1.329 + proc MakeLink {a} {
1.330 + namespace eval ::test_ns_1 {
1.331 + upvar a a
1.332 + }
1.333 + unset ::test_ns_1::a
1.334 + }
1.335 + list [catch {MakeLink 1} msg] $msg
1.336 +} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}
1.337 +test upvar-8.10 {upvar will create element alias for new array element} {
1.338 + catch {unset upvarArray}
1.339 + array set upvarArray {}
1.340 + catch {upvar 0 upvarArray(elem) upvarArrayElemAlias}
1.341 +} {0}
1.342 +
1.343 +if {[info commands testupvar] != {}} {
1.344 + test upvar-9.1 {Tcl_UpVar2 procedure} {
1.345 + list [catch {testupvar xyz a {} x global} msg] $msg
1.346 + } {1 {bad level "xyz"}}
1.347 + test upvar-9.2 {Tcl_UpVar2 procedure} {
1.348 + catch {unset a}
1.349 + catch {unset x}
1.350 + set a 44
1.351 + list [catch {testupvar #0 a 1 x global} msg] $msg
1.352 + } {1 {can't access "a(1)": variable isn't array}}
1.353 + test upvar-9.3 {Tcl_UpVar2 procedure} {
1.354 + proc foo {} {
1.355 + testupvar 1 a {} x local
1.356 + set x
1.357 + }
1.358 + catch {unset a}
1.359 + catch {unset x}
1.360 + set a 44
1.361 + foo
1.362 + } {44}
1.363 + test upvar-9.4 {Tcl_UpVar2 procedure} {
1.364 + proc foo {} {
1.365 + testupvar 1 a {} _up_ global
1.366 + list [catch {set x} msg] $msg
1.367 + }
1.368 + catch {unset a}
1.369 + catch {unset _up_}
1.370 + set a 44
1.371 + concat [foo] $_up_
1.372 + } {1 {can't read "x": no such variable} 44}
1.373 + test upvar-9.5 {Tcl_UpVar2 procedure} {
1.374 + proc foo {} {
1.375 + testupvar 1 a b x local
1.376 + set x
1.377 + }
1.378 + catch {unset a}
1.379 + catch {unset x}
1.380 + set a(b) 1234
1.381 + foo
1.382 + } {1234}
1.383 + test upvar-9.6 {Tcl_UpVar procedure} {
1.384 + proc foo {} {
1.385 + testupvar 1 a x local
1.386 + set x
1.387 + }
1.388 + catch {unset a}
1.389 + catch {unset x}
1.390 + set a xyzzy
1.391 + foo
1.392 + } {xyzzy}
1.393 + test upvar-9.7 {Tcl_UpVar procedure} {
1.394 + proc foo {} {
1.395 + testupvar #0 a(b) x local
1.396 + set x
1.397 + }
1.398 + catch {unset a}
1.399 + catch {unset x}
1.400 + set a(b) 1234
1.401 + foo
1.402 + } {1234}
1.403 +}
1.404 +catch {unset a}
1.405 +
1.406 +# cleanup
1.407 +::tcltest::cleanupTests
1.408 +return
1.409 +
1.410 +
1.411 +
1.412 +
1.413 +
1.414 +
1.415 +
1.416 +
1.417 +
1.418 +
1.419 +
1.420 +