| author | sl@SLION-WIN7.fritz.box |
| Fri, 15 Jun 2012 03:10:57 +0200 | |
| changeset 0 | bde4ae8d615e |
| permissions | -rw-r--r-- |
| sl@0 | 1 |
# Commands covered: uplevel |
| sl@0 | 2 |
# |
| sl@0 | 3 |
# This file contains a collection of tests for one or more of the Tcl |
| sl@0 | 4 |
# built-in commands. Sourcing this file into Tcl runs the tests and |
| sl@0 | 5 |
# generates output for errors. No output means no errors were found. |
| sl@0 | 6 |
# |
| sl@0 | 7 |
# Copyright (c) 1991-1993 The Regents of the University of California. |
| sl@0 | 8 |
# Copyright (c) 1994 Sun Microsystems, Inc. |
| sl@0 | 9 |
# Copyright (c) 1998-1999 by Scriptics Corporation. |
| sl@0 | 10 |
# |
| sl@0 | 11 |
# See the file "license.terms" for information on usage and redistribution |
| sl@0 | 12 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| sl@0 | 13 |
# |
| sl@0 | 14 |
# RCS: @(#) $Id: uplevel.test,v 1.7 2002/08/08 18:19:37 msofer Exp $ |
| sl@0 | 15 |
|
| sl@0 | 16 |
if {[lsearch [namespace children] ::tcltest] == -1} {
|
| sl@0 | 17 |
package require tcltest |
| sl@0 | 18 |
namespace import -force ::tcltest::* |
| sl@0 | 19 |
} |
| sl@0 | 20 |
|
| sl@0 | 21 |
proc a {x y} {
|
| sl@0 | 22 |
newset z [expr $x+$y] |
| sl@0 | 23 |
return $z |
| sl@0 | 24 |
} |
| sl@0 | 25 |
proc newset {name value} {
|
| sl@0 | 26 |
uplevel set $name $value |
| sl@0 | 27 |
uplevel 1 {uplevel 1 {set xyz 22}}
|
| sl@0 | 28 |
} |
| sl@0 | 29 |
|
| sl@0 | 30 |
test uplevel-1.1 {simple operation} {
|
| sl@0 | 31 |
set xyz 0 |
| sl@0 | 32 |
a 22 33 |
| sl@0 | 33 |
} 55 |
| sl@0 | 34 |
test uplevel-1.2 {command is another uplevel command} {
|
| sl@0 | 35 |
set xyz 0 |
| sl@0 | 36 |
a 22 33 |
| sl@0 | 37 |
set xyz |
| sl@0 | 38 |
} 22 |
| sl@0 | 39 |
|
| sl@0 | 40 |
proc a1 {} {
|
| sl@0 | 41 |
b1 |
| sl@0 | 42 |
global a a1 |
| sl@0 | 43 |
set a $x |
| sl@0 | 44 |
set a1 $y |
| sl@0 | 45 |
} |
| sl@0 | 46 |
proc b1 {} {
|
| sl@0 | 47 |
c1 |
| sl@0 | 48 |
global b b1 |
| sl@0 | 49 |
set b $x |
| sl@0 | 50 |
set b1 $y |
| sl@0 | 51 |
} |
| sl@0 | 52 |
proc c1 {} {
|
| sl@0 | 53 |
uplevel 1 set x 111 |
| sl@0 | 54 |
uplevel #2 set y 222 |
| sl@0 | 55 |
uplevel 2 set x 333 |
| sl@0 | 56 |
uplevel #1 set y 444 |
| sl@0 | 57 |
uplevel 3 set x 555 |
| sl@0 | 58 |
uplevel #0 set y 666 |
| sl@0 | 59 |
} |
| sl@0 | 60 |
a1 |
| sl@0 | 61 |
test uplevel-2.1 {relative and absolute uplevel} {set a} 333
|
| sl@0 | 62 |
test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
|
| sl@0 | 63 |
test uplevel-2.3 {relative and absolute uplevel} {set b} 111
|
| sl@0 | 64 |
test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
|
| sl@0 | 65 |
test uplevel-2.5 {relative and absolute uplevel} {set x} 555
|
| sl@0 | 66 |
test uplevel-2.6 {relative and absolute uplevel} {set y} 666
|
| sl@0 | 67 |
|
| sl@0 | 68 |
test uplevel-3.1 {uplevel to same level} {
|
| sl@0 | 69 |
set x 33 |
| sl@0 | 70 |
uplevel #0 set x 44 |
| sl@0 | 71 |
set x |
| sl@0 | 72 |
} 44 |
| sl@0 | 73 |
test uplevel-3.2 {uplevel to same level} {
|
| sl@0 | 74 |
set x 33 |
| sl@0 | 75 |
uplevel 0 set x |
| sl@0 | 76 |
} 33 |
| sl@0 | 77 |
test uplevel-3.3 {uplevel to same level} {
|
| sl@0 | 78 |
set y xxx |
| sl@0 | 79 |
proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
|
| sl@0 | 80 |
a1 |
| sl@0 | 81 |
} 66 |
| sl@0 | 82 |
test uplevel-3.4 {uplevel to same level} {
|
| sl@0 | 83 |
set y zzz |
| sl@0 | 84 |
proc a1 {} {set y 55; uplevel #1 set y}
|
| sl@0 | 85 |
a1 |
| sl@0 | 86 |
} 55 |
| sl@0 | 87 |
|
| sl@0 | 88 |
test uplevel-4.1 {error: non-existent level} {
|
| sl@0 | 89 |
list [catch c1 msg] $msg |
| sl@0 | 90 |
} {1 {bad level "#2"}}
|
| sl@0 | 91 |
test uplevel-4.2 {error: non-existent level} {
|
| sl@0 | 92 |
proc c2 {} {uplevel 3 {set a b}}
|
| sl@0 | 93 |
list [catch c2 msg] $msg |
| sl@0 | 94 |
} {1 {bad level "3"}}
|
| sl@0 | 95 |
test uplevel-4.3 {error: not enough args} {
|
| sl@0 | 96 |
list [catch uplevel msg] $msg |
| sl@0 | 97 |
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
|
| sl@0 | 98 |
test uplevel-4.4 {error: not enough args} {
|
| sl@0 | 99 |
proc upBug {} {uplevel 1}
|
| sl@0 | 100 |
list [catch upBug msg] $msg |
| sl@0 | 101 |
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
|
| sl@0 | 102 |
|
| sl@0 | 103 |
proc a2 {} {
|
| sl@0 | 104 |
uplevel a3 |
| sl@0 | 105 |
} |
| sl@0 | 106 |
proc a3 {} {
|
| sl@0 | 107 |
global x y |
| sl@0 | 108 |
set x [info level] |
| sl@0 | 109 |
set y [info level 1] |
| sl@0 | 110 |
} |
| sl@0 | 111 |
a2 |
| sl@0 | 112 |
test uplevel-5.1 {info level} {set x} 1
|
| sl@0 | 113 |
test uplevel-5.2 {info level} {set y} a3
|
| sl@0 | 114 |
|
| sl@0 | 115 |
namespace eval ns1 {
|
| sl@0 | 116 |
proc set args {return ::ns1}
|
| sl@0 | 117 |
} |
| sl@0 | 118 |
proc a2 {} {
|
| sl@0 | 119 |
uplevel {set x ::}
|
| sl@0 | 120 |
} |
| sl@0 | 121 |
test uplevel-6.1 {uplevel and shadowed cmds} {
|
| sl@0 | 122 |
set res [namespace eval ns1 a2] |
| sl@0 | 123 |
lappend res [namespace eval ns2 a2] |
| sl@0 | 124 |
lappend res [namespace eval ns1 a2] |
| sl@0 | 125 |
namespace eval ns1 {rename set {}}
|
| sl@0 | 126 |
lappend res [namespace eval ns1 a2] |
| sl@0 | 127 |
} {::ns1 :: ::ns1 ::}
|
| sl@0 | 128 |
|
| sl@0 | 129 |
|
| sl@0 | 130 |
# cleanup |
| sl@0 | 131 |
::tcltest::cleanupTests |
| sl@0 | 132 |
return |
| sl@0 | 133 |
|
| sl@0 | 134 |
|
| sl@0 | 135 |
|
| sl@0 | 136 |
|
| sl@0 | 137 |
|
| sl@0 | 138 |
|
| sl@0 | 139 |
|
| sl@0 | 140 |
|
| sl@0 | 141 |
|
| sl@0 | 142 |
|
| sl@0 | 143 |
|
| sl@0 | 144 |