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