os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/uplevel.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/uplevel.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,144 @@
1.4 +# Commands covered: uplevel
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: uplevel.test,v 1.7 2002/08/08 18:19:37 msofer 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 +proc a {x y} {
1.25 + newset z [expr $x+$y]
1.26 + return $z
1.27 +}
1.28 +proc newset {name value} {
1.29 + uplevel set $name $value
1.30 + uplevel 1 {uplevel 1 {set xyz 22}}
1.31 +}
1.32 +
1.33 +test uplevel-1.1 {simple operation} {
1.34 + set xyz 0
1.35 + a 22 33
1.36 +} 55
1.37 +test uplevel-1.2 {command is another uplevel command} {
1.38 + set xyz 0
1.39 + a 22 33
1.40 + set xyz
1.41 +} 22
1.42 +
1.43 +proc a1 {} {
1.44 + b1
1.45 + global a a1
1.46 + set a $x
1.47 + set a1 $y
1.48 +}
1.49 +proc b1 {} {
1.50 + c1
1.51 + global b b1
1.52 + set b $x
1.53 + set b1 $y
1.54 +}
1.55 +proc c1 {} {
1.56 + uplevel 1 set x 111
1.57 + uplevel #2 set y 222
1.58 + uplevel 2 set x 333
1.59 + uplevel #1 set y 444
1.60 + uplevel 3 set x 555
1.61 + uplevel #0 set y 666
1.62 +}
1.63 +a1
1.64 +test uplevel-2.1 {relative and absolute uplevel} {set a} 333
1.65 +test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
1.66 +test uplevel-2.3 {relative and absolute uplevel} {set b} 111
1.67 +test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
1.68 +test uplevel-2.5 {relative and absolute uplevel} {set x} 555
1.69 +test uplevel-2.6 {relative and absolute uplevel} {set y} 666
1.70 +
1.71 +test uplevel-3.1 {uplevel to same level} {
1.72 + set x 33
1.73 + uplevel #0 set x 44
1.74 + set x
1.75 +} 44
1.76 +test uplevel-3.2 {uplevel to same level} {
1.77 + set x 33
1.78 + uplevel 0 set x
1.79 +} 33
1.80 +test uplevel-3.3 {uplevel to same level} {
1.81 + set y xxx
1.82 + proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
1.83 + a1
1.84 +} 66
1.85 +test uplevel-3.4 {uplevel to same level} {
1.86 + set y zzz
1.87 + proc a1 {} {set y 55; uplevel #1 set y}
1.88 + a1
1.89 +} 55
1.90 +
1.91 +test uplevel-4.1 {error: non-existent level} {
1.92 + list [catch c1 msg] $msg
1.93 +} {1 {bad level "#2"}}
1.94 +test uplevel-4.2 {error: non-existent level} {
1.95 + proc c2 {} {uplevel 3 {set a b}}
1.96 + list [catch c2 msg] $msg
1.97 +} {1 {bad level "3"}}
1.98 +test uplevel-4.3 {error: not enough args} {
1.99 + list [catch uplevel msg] $msg
1.100 +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
1.101 +test uplevel-4.4 {error: not enough args} {
1.102 + proc upBug {} {uplevel 1}
1.103 + list [catch upBug msg] $msg
1.104 +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
1.105 +
1.106 +proc a2 {} {
1.107 + uplevel a3
1.108 +}
1.109 +proc a3 {} {
1.110 + global x y
1.111 + set x [info level]
1.112 + set y [info level 1]
1.113 +}
1.114 +a2
1.115 +test uplevel-5.1 {info level} {set x} 1
1.116 +test uplevel-5.2 {info level} {set y} a3
1.117 +
1.118 +namespace eval ns1 {
1.119 + proc set args {return ::ns1}
1.120 +}
1.121 +proc a2 {} {
1.122 + uplevel {set x ::}
1.123 +}
1.124 +test uplevel-6.1 {uplevel and shadowed cmds} {
1.125 + set res [namespace eval ns1 a2]
1.126 + lappend res [namespace eval ns2 a2]
1.127 + lappend res [namespace eval ns1 a2]
1.128 + namespace eval ns1 {rename set {}}
1.129 + lappend res [namespace eval ns1 a2]
1.130 +} {::ns1 :: ::ns1 ::}
1.131 +
1.132 +
1.133 +# cleanup
1.134 +::tcltest::cleanupTests
1.135 +return
1.136 +
1.137 +
1.138 +
1.139 +
1.140 +
1.141 +
1.142 +
1.143 +
1.144 +
1.145 +
1.146 +
1.147 +