#
|
#
|
# Tests for code/scope commands
|
# Tests for code/scope commands
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# AUTHOR: Michael J. McLennan
|
# AUTHOR: Michael J. McLennan
|
# Bell Labs Innovations for Lucent Technologies
|
# Bell Labs Innovations for Lucent Technologies
|
# mmclennan@lucent.com
|
# mmclennan@lucent.com
|
# http://www.tcltk.com/itcl
|
# http://www.tcltk.com/itcl
|
#
|
#
|
# RCS: $Id: scope.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# RCS: $Id: scope.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# ======================================================================
|
# ======================================================================
|
# See the file "license.terms" for information on usage and
|
# See the file "license.terms" for information on usage and
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Syntax of the "scope" command
|
# Syntax of the "scope" command
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test scope-1.1 {scope command takes one argument} {
|
test scope-1.1 {scope command takes one argument} {
|
list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg
|
list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg
|
} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}}
|
} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}}
|
|
|
test scope-1.2 {argument to scope command must be a variable} {
|
test scope-1.2 {argument to scope command must be a variable} {
|
variable test_scope_var 0
|
variable test_scope_var 0
|
list [catch {itcl::scope xyzzy} msg] $msg \
|
list [catch {itcl::scope xyzzy} msg] $msg \
|
[catch {itcl::scope test_scope_var} msg] $msg
|
[catch {itcl::scope test_scope_var} msg] $msg
|
} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var}
|
} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var}
|
|
|
test scope-1.3 {if variable is already fully qualified, scope does nothing} {
|
test scope-1.3 {if variable is already fully qualified, scope does nothing} {
|
list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var]
|
list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var]
|
} {::xyzzy ::test_scope_var}
|
} {::xyzzy ::test_scope_var}
|
|
|
test scope-1.4 {scope command returns fully qualified name} {
|
test scope-1.4 {scope command returns fully qualified name} {
|
namespace eval test_scope_ns {
|
namespace eval test_scope_ns {
|
namespace eval child {
|
namespace eval child {
|
variable v1 0
|
variable v1 0
|
itcl::scope v1
|
itcl::scope v1
|
}
|
}
|
}
|
}
|
} {::test_scope_ns::child::v1}
|
} {::test_scope_ns::child::v1}
|
|
|
namespace delete test_scope_ns
|
namespace delete test_scope_ns
|
unset test_scope_var
|
unset test_scope_var
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Syntax of the "code" command
|
# Syntax of the "code" command
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test scope-2.1 {code command takes at least one argument} {
|
test scope-2.1 {code command takes at least one argument} {
|
list [catch {itcl::code} msg] $msg
|
list [catch {itcl::code} msg] $msg
|
} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}}
|
} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}}
|
|
|
test scope-2.2 {code command with one argument} {
|
test scope-2.2 {code command with one argument} {
|
itcl::code arg1
|
itcl::code arg1
|
} {namespace inscope :: arg1}
|
} {namespace inscope :: arg1}
|
|
|
test scope-2.3 {code command with many arguments} {
|
test scope-2.3 {code command with many arguments} {
|
list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4]
|
list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4]
|
} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}}
|
} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}}
|
|
|
test scope-2.4 {code command appends arguments as list elements} {
|
test scope-2.4 {code command appends arguments as list elements} {
|
list [itcl::code "foo bar"] \
|
list [itcl::code "foo bar"] \
|
[itcl::code "foo bar" "hello, world!" "one, two, three"]
|
[itcl::code "foo bar" "hello, world!" "one, two, three"]
|
} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}}
|
} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}}
|
|
|
test scope-2.5 {code command inside code command} {
|
test scope-2.5 {code command inside code command} {
|
itcl::code [itcl::code arg1 arg2] arg3
|
itcl::code [itcl::code arg1 arg2] arg3
|
} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}}
|
} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}}
|
|
|
test scope-2.6 {code command returns fully qualified names} {
|
test scope-2.6 {code command returns fully qualified names} {
|
namespace eval test_scope_ns {
|
namespace eval test_scope_ns {
|
namespace eval child {
|
namespace eval child {
|
itcl::code foo bar baz
|
itcl::code foo bar baz
|
}
|
}
|
}
|
}
|
} {namespace inscope ::test_scope_ns::child {foo bar baz}}
|
} {namespace inscope ::test_scope_ns::child {foo bar baz}}
|
|
|
test scope-2.7 {code command lets you specify a namespace} {
|
test scope-2.7 {code command lets you specify a namespace} {
|
list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \
|
list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \
|
[catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg
|
[catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg
|
} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}}
|
} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}}
|
|
|
test scope-2.8 {last namespace wins} {
|
test scope-2.8 {last namespace wins} {
|
itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1
|
itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1
|
} {namespace inscope ::test_scope_ns arg1}
|
} {namespace inscope ::test_scope_ns arg1}
|
|
|
test scope-2.9 {"--" terminates switches} {
|
test scope-2.9 {"--" terminates switches} {
|
list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \
|
list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \
|
[catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg
|
[catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg
|
|
|
} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}}
|
} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}}
|
|
|
namespace delete test_scope_ns
|
namespace delete test_scope_ns
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Test code/scope commands in a class
|
# Test code/scope commands in a class
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test scope-3.1 {define simple classes with things to export} {
|
test scope-3.1 {define simple classes with things to export} {
|
itcl::class test_scope {
|
itcl::class test_scope {
|
private variable priv "private-value"
|
private variable priv "private-value"
|
protected variable prov "protected-value"
|
protected variable prov "protected-value"
|
public variable pubv "public-value"
|
public variable pubv "public-value"
|
|
|
private common pric "private-common-value"
|
private common pric "private-common-value"
|
protected common proc "protected-common-value"
|
protected common proc "protected-common-value"
|
public common pubc "public-common-value"
|
public common pubc "public-common-value"
|
|
|
variable varray
|
variable varray
|
common carray
|
common carray
|
|
|
method mcontext {args} {
|
method mcontext {args} {
|
return [eval $args]
|
return [eval $args]
|
}
|
}
|
proc pcontext {args} {
|
proc pcontext {args} {
|
return [eval $args]
|
return [eval $args]
|
}
|
}
|
|
|
private method prim {args} {
|
private method prim {args} {
|
return "prim: $args"
|
return "prim: $args"
|
}
|
}
|
protected method prom {args} {
|
protected method prom {args} {
|
return "prom: $args"
|
return "prom: $args"
|
}
|
}
|
public method pubm {args} {
|
public method pubm {args} {
|
return "pubm: $args"
|
return "pubm: $args"
|
}
|
}
|
}
|
}
|
test_scope #auto
|
test_scope #auto
|
} {test_scope0}
|
} {test_scope0}
|
|
|
test scope-3.2 {code command captures only class context} {
|
test scope-3.2 {code command captures only class context} {
|
list [test_scope0 mcontext itcl::code arg1 arg2] \
|
list [test_scope0 mcontext itcl::code arg1 arg2] \
|
[test_scope::pcontext itcl::code arg1 arg2]
|
[test_scope::pcontext itcl::code arg1 arg2]
|
} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}}
|
} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}}
|
|
|
test scope-3.3 {scope command captures class and object context} {
|
test scope-3.3 {scope command captures class and object context} {
|
list [test_scope0 mcontext itcl::scope priv] \
|
list [test_scope0 mcontext itcl::scope priv] \
|
[test_scope::pcontext itcl::scope pric]
|
[test_scope::pcontext itcl::scope pric]
|
} {{@itcl ::test_scope0 ::test_scope::priv} ::test_scope::pric}
|
} {{@itcl ::test_scope0 ::test_scope::priv} ::test_scope::pric}
|
|
|
test scope-3.4 {scope command must recognize variable} {
|
test scope-3.4 {scope command must recognize variable} {
|
list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg
|
list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg
|
} {1 {variable "xyzzy" not found in class "::test_scope"}}
|
} {1 {variable "xyzzy" not found in class "::test_scope"}}
|
|
|
test scope-3.5 {scope command provides access to instance variables} {
|
test scope-3.5 {scope command provides access to instance variables} {
|
set result ""
|
set result ""
|
foreach vname {priv prov pubv} {
|
foreach vname {priv prov pubv} {
|
lappend result [test_scope0 info variable $vname]
|
lappend result [test_scope0 info variable $vname]
|
set var [test_scope0 mcontext itcl::scope $vname]
|
set var [test_scope0 mcontext itcl::scope $vname]
|
set $var "$vname-new"
|
set $var "$vname-new"
|
lappend result [test_scope0 info variable $vname]
|
lappend result [test_scope0 info variable $vname]
|
}
|
}
|
set result
|
set result
|
} {{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}}
|
} {{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}}
|
|
|
test scope-3.6 {scope command provides access to common variables} {
|
test scope-3.6 {scope command provides access to common variables} {
|
set result ""
|
set result ""
|
foreach vname {pric proc pubc} {
|
foreach vname {pric proc pubc} {
|
lappend result [test_scope0 info variable $vname]
|
lappend result [test_scope0 info variable $vname]
|
set var [test_scope0 mcontext itcl::scope $vname]
|
set var [test_scope0 mcontext itcl::scope $vname]
|
set $var "$vname-new"
|
set $var "$vname-new"
|
lappend result [test_scope0 info variable $vname]
|
lappend result [test_scope0 info variable $vname]
|
}
|
}
|
set result
|
set result
|
} {{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}}
|
} {{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}}
|
|
|
test scope-3.7 {code command provides access to methods} {
|
test scope-3.7 {code command provides access to methods} {
|
set result ""
|
set result ""
|
foreach mname {prim prom pubm} {
|
foreach mname {prim prom pubm} {
|
set cmd [test_scope0 mcontext eval itcl::code \$this $mname]
|
set cmd [test_scope0 mcontext eval itcl::code \$this $mname]
|
lappend result $cmd [$cmd 1 2 3]
|
lappend result $cmd [$cmd 1 2 3]
|
}
|
}
|
set result
|
set result
|
} {{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}}
|
} {{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}}
|
|
|
test scope-3.8 {scope command allows access to slots in an array} {
|
test scope-3.8 {scope command allows access to slots in an array} {
|
test_scope0 mcontext set varray(0) "defined"
|
test_scope0 mcontext set varray(0) "defined"
|
test_scope::pcontext set carray(0) "defined"
|
test_scope::pcontext set carray(0) "defined"
|
list [catch {test_scope0 mcontext scope varray(0)} msg] $msg \
|
list [catch {test_scope0 mcontext scope varray(0)} msg] $msg \
|
[catch {test_scope0 mcontext scope varray(1)} msg] $msg \
|
[catch {test_scope0 mcontext scope varray(1)} msg] $msg \
|
[catch {test_scope::pcontext scope carray(0)} msg] $msg \
|
[catch {test_scope::pcontext scope carray(0)} msg] $msg \
|
[catch {test_scope::pcontext scope carray(1)} msg] $msg
|
[catch {test_scope::pcontext scope carray(1)} msg] $msg
|
} {0 {@itcl ::test_scope0 ::test_scope::varray(0)} 0 {@itcl ::test_scope0 ::test_scope::varray(1)} 0 ::test_scope::carray(0) 0 ::test_scope::carray(1)}
|
} {0 {@itcl ::test_scope0 ::test_scope::varray(0)} 0 {@itcl ::test_scope0 ::test_scope::varray(1)} 0 ::test_scope::carray(0) 0 ::test_scope::carray(1)}
|
|
|
itcl::delete class test_scope
|
itcl::delete class test_scope
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Test code/scope commands in a namespace
|
# Test code/scope commands in a namespace
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test scope-4.1 {define simple namespace with things to export} {
|
test scope-4.1 {define simple namespace with things to export} {
|
namespace eval test_scope_ns {
|
namespace eval test_scope_ns {
|
variable array
|
variable array
|
proc pcontext {args} {
|
proc pcontext {args} {
|
return [eval $args]
|
return [eval $args]
|
}
|
}
|
}
|
}
|
namespace children :: ::test_scope_ns
|
namespace children :: ::test_scope_ns
|
} {::test_scope_ns}
|
} {::test_scope_ns}
|
|
|
test scope-4.2 {scope command allows access to slots in an array} {
|
test scope-4.2 {scope command allows access to slots in an array} {
|
test_scope_ns::pcontext set array(0) "defined"
|
test_scope_ns::pcontext set array(0) "defined"
|
list [catch {test_scope_ns::pcontext scope array(0)} msg] $msg \
|
list [catch {test_scope_ns::pcontext scope array(0)} msg] $msg \
|
[catch {test_scope_ns::pcontext scope array(1)} msg] $msg
|
[catch {test_scope_ns::pcontext scope array(1)} msg] $msg
|
} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}
|
} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}
|
|
|
namespace delete test_scope_ns
|
namespace delete test_scope_ns
|
|
|
