1# 2# Tests for code/scope commands 3# ---------------------------------------------------------------------- 4# AUTHOR: Michael J. McLennan 5# Bell Labs Innovations for Lucent Technologies 6# mmclennan@lucent.com 7# http://www.tcltk.com/itcl 8# ---------------------------------------------------------------------- 9# Copyright (c) 1993-1998 Lucent Technologies, Inc. 10# ====================================================================== 11# See the file "license.terms" for information on usage and 12# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14package require tcltest 2.1 15namespace import ::tcltest::test 16::tcltest::loadTestedCommands 17package require itcl 18 19# ---------------------------------------------------------------------- 20# Syntax of the "scope" command 21# ---------------------------------------------------------------------- 22test scope-1.1 {scope command takes one argument} { 23 list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg 24} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}} 25 26test scope-1.2 {argument to scope command must be a variable} { 27 variable test_scope_var 0 28 list [catch {itcl::scope xyzzy} msg] $msg \ 29 [catch {itcl::scope test_scope_var} msg] $msg 30} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var} 31 32test scope-1.3 {if variable is already fully qualified, scope does nothing} { 33 list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var] 34} {::xyzzy ::test_scope_var} 35 36test scope-1.4 {scope command returns fully qualified name} { 37 namespace eval test_scope_ns { 38 namespace eval child { 39 variable v1 0 40 itcl::scope v1 41 } 42 } 43} {::test_scope_ns::child::v1} 44 45namespace delete test_scope_ns 46unset test_scope_var 47 48# ---------------------------------------------------------------------- 49# Syntax of the "code" command 50# ---------------------------------------------------------------------- 51test scope-2.1 {code command takes at least one argument} { 52 list [catch {itcl::code} msg] $msg 53} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}} 54 55test scope-2.2 {code command with one argument} { 56 itcl::code arg1 57} {namespace inscope :: arg1} 58 59test scope-2.3 {code command with many arguments} { 60 list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4] 61} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}} 62 63test scope-2.4 {code command appends arguments as list elements} { 64 list [itcl::code "foo bar"] \ 65 [itcl::code "foo bar" "hello, world!" "one, two, three"] 66} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}} 67 68test scope-2.5 {code command inside code command} { 69 itcl::code [itcl::code arg1 arg2] arg3 70} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}} 71 72test scope-2.6 {code command returns fully qualified names} { 73 namespace eval test_scope_ns { 74 namespace eval child { 75 itcl::code foo bar baz 76 } 77 } 78} {namespace inscope ::test_scope_ns::child {foo bar baz}} 79 80test scope-2.7 {code command lets you specify a namespace} { 81 list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \ 82 [catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg 83} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}} 84 85test scope-2.8 {last namespace wins} { 86 itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1 87} {namespace inscope ::test_scope_ns arg1} 88 89test scope-2.9 {"--" terminates switches} { 90 list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \ 91 [catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg 92} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}} 93 94namespace delete test_scope_ns 95 96# ---------------------------------------------------------------------- 97# Test code/scope commands in a class 98# ---------------------------------------------------------------------- 99test scope-3.1 {define simple classes with things to export} { 100 itcl::class test_scope { 101 private variable priv "private-value" 102 protected variable prov "protected-value" 103 public variable pubv "public-value" 104 105 private common pric "private-common-value" 106 protected common proc "protected-common-value" 107 public common pubc "public-common-value" 108 109 variable varray 110 common carray 111 112 method mcontext {args} { 113 return [eval $args] 114 } 115 proc pcontext {args} { 116 return [eval $args] 117 } 118 119 private method prim {args} { 120 return "prim: $args" 121 } 122 protected method prom {args} { 123 return "prom: $args" 124 } 125 public method pubm {args} { 126 return "pubm: $args" 127 } 128 } 129 test_scope #auto 130} {test_scope0} 131 132test scope-3.2 {code command captures only class context} { 133 list [test_scope0 mcontext itcl::code arg1 arg2] \ 134 [test_scope::pcontext itcl::code arg1 arg2] 135} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}} 136 137test scope-3.3 {scope command captures class and object context} -body { 138 list [test_scope0 mcontext itcl::scope priv] \ 139 [test_scope::pcontext itcl::scope pric] 140} -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::test_scope::pric} 141 142test scope-3.4 {scope command must recognize variable} { 143 list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg 144} {1 {variable "xyzzy" not found in class "::test_scope"}} 145 146test scope-3.5 {scope command provides access to instance variables} { 147 set result "" 148 foreach vname {priv prov pubv} { 149 lappend result [test_scope0 info variable $vname] 150 set var [test_scope0 mcontext itcl::scope $vname] 151 set $var "$vname-new" 152 lappend result [test_scope0 info variable $vname] 153 } 154 set result 155} {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}} 156 157test scope-3.6 {scope command provides access to common variables} { 158 set result "" 159 foreach vname {pric proc pubc} { 160 lappend result [test_scope0 info variable $vname] 161 set var [test_scope0 mcontext itcl::scope $vname] 162 set $var "$vname-new" 163 lappend result [test_scope0 info variable $vname] 164 } 165 set result 166} {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}} 167 168test scope-3.7 {code command provides access to methods} { 169 set result "" 170 foreach mname {prim prom pubm} { 171 set cmd [test_scope0 mcontext eval itcl::code \$this $mname] 172 lappend result $cmd [uplevel 0 $cmd 1 2 3] 173 } 174 set result 175} {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}} 176 177test scope-3.8 {scope command allows access to slots in an array} -body { 178 test_scope0 mcontext set varray(0) "defined" 179 test_scope::pcontext set carray(0) "defined" 180 list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \ 181 [catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \ 182 [catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \ 183 [catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg 184} -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::test_scope::carray(1)} 185 186itcl::delete class test_scope 187 188# ---------------------------------------------------------------------- 189# Test code/scope commands in a namespace 190# ---------------------------------------------------------------------- 191test scope-4.1 {define simple namespace with things to export} { 192 namespace eval test_scope_ns { 193 variable array 194 proc pcontext {args} { 195 return [eval $args] 196 } 197 } 198 namespace children :: ::test_scope_ns 199} {::test_scope_ns} 200 201test scope-4.2 {scope command allows access to slots in an array} { 202 test_scope_ns::pcontext set array(0) "defined" 203 list [catch {test_scope_ns::pcontext itcl::scope array(0)} msg] $msg \ 204 [catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg 205} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)} 206 207namespace delete test_scope_ns 208 209test scope-5.0 {Bug e5f529da75} -setup { 210 itcl::class B { 211 common c 212 method v {} {itcl::scope c} 213 } 214 itcl::class D { 215 inherit B 216 method v {} {itcl::scope c} 217 } 218 B b 219 D d 220} -body { 221 string equal [b v] [d v] 222} -cleanup { 223 itcl::delete class B 224} -result 1 225 226::tcltest::cleanupTests 227return 228