--- /dev/null
+#
+# Basic tests for class definition and method/proc access
+# ----------------------------------------------------------------------
+# AUTHOR: Michael J. McLennan
+# Bell Labs Innovations for Lucent Technologies
+# mmclennan@lucent.com
+# http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+# Copyright (c) 1993-1998 Lucent Technologies, Inc.
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+test basic-1.0 {empty string as class name should fail but not crash
+} -body {
+ list [catch {itcl::class "" {}} err] $err
+} -result {1 {invalid class name ""}}
+
+# ----------------------------------------------------------------------
+# Simple class definition
+# ----------------------------------------------------------------------
+
+variable setup {
+ itcl::class Counter {
+ constructor {args} {
+ incr num
+ eval configure $args
+ }
+ destructor {
+ if {![info exists num]} {
+ lappend ::tcltest::itcl_basic_errors "unexpected: common deleted before destructor got called"
+ }
+ incr num -1
+ }
+
+ method ++ {} {
+ return [incr val $by]
+ }
+ proc num {} {
+ return $num
+ }
+ public variable by 1
+ protected variable val 0
+ private common num 0
+ }
+}
+
+variable cleanup {
+ itcl::delete class Counter
+}
+
+variable setup2 $setup
+append setup2 {
+ set x [Counter x]
+}
+
+variable cleanup2 $cleanup
+append cleanup2 {
+ unset x
+}
+
+variable setup3 $setup
+append setup3 {
+ Counter -foo
+}
+
+variable setup4 $setup
+append setup4 {
+ Counter c
+}
+
+proc check_itcl_basic_errors {} {
+ if {[info exists ::tcltest::itcl_basic_errors] && [llength $::tcltest::itcl_basic_errors]} {
+ error "following errors occurs during tests:\n [join $::tcltest::itcl_basic_errors "\n "]"
+ }
+}
+
+test basic-1.1 {define a simple class
+} -setup $setup -body {
+} -cleanup $cleanup -result {}
+
+test basic-1.2 {class is now defined
+} -setup $setup -body {
+ itcl::find classes Counter
+} -cleanup $cleanup -result Counter
+
+test basic-1.3 {access command exists with class name
+} -setup $setup -body {
+ namespace which -command Counter
+} -cleanup $cleanup -result ::Counter
+
+test basic-1.4 {create a simple object
+} -setup $setup2 -body {
+ return $x
+} -cleanup $cleanup2 -result x
+
+test basic-1.5a {object names cannot be duplicated
+} -setup $setup2 -body {
+ list [catch "Counter x" msg] $msg
+} -cleanup $cleanup2 -result {1 {command "x" already exists in namespace "::"}}
+
+test basic-1.5b {built-in commands cannot be clobbered
+} -setup $setup -body {
+ list [catch "Counter info" msg] $msg
+} -cleanup $cleanup -result {1 {command "info" already exists in namespace "::"}}
+
+test basic-1.6 {objects have an access command
+} -setup $setup2 -body {
+ namespace which -command x
+} -cleanup $cleanup2 -result ::x
+
+test basic-1.7a {objects are added to the global list
+} -setup $setup2 -body {
+ itcl::find objects x
+} -cleanup $cleanup2 -result x
+
+test basic-1.7b {objects are added to the global list
+} -setup $setup2 -body {
+ itcl::find objects -class Counter x
+} -cleanup $cleanup2 -result x
+
+test basic-1.8 {objects can be deleted
+} -setup $setup2 -body {
+ list [itcl::delete object x] [namespace which -command x]
+} -cleanup $cleanup2 -result {{} {}}
+
+test basic-1.9 {objects can be recreated with the same name
+} -setup $setup2 -body {
+ itcl::delete object x
+ Counter x
+} -cleanup $cleanup2 -result x
+
+test basic-1.10 {objects can be destroyed by deleting their access command
+} -setup $setup2 -body {
+ rename ::x {}
+ itcl::find objects x
+} -cleanup $cleanup2 -result {}
+
+test basic-1.11 {find command supports object names starting with -
+} -setup $setup3 -body {
+ itcl::find objects -class Counter -foo
+} -cleanup $cleanup -result -foo
+
+test basic-1.12 {is command with class argument
+} -setup $setup -body {
+ itcl::is class Counter
+} -cleanup $cleanup -result 1
+
+test basic-1.13 {is command with class argument (global namespace)
+} -setup $setup -body {
+ itcl::is class ::Counter
+} -cleanup $cleanup -result 1
+
+test basic-1.14 {is command with class argument (wrapped in code command)
+} -setup $setup -body {
+ itcl::is class [itcl::code Counter]
+} -cleanup $cleanup -result 1
+
+test basic-1.15 {is command with class argument (class does not exist)
+} -body {
+ itcl::is class Count
+} -result 0
+
+test basic-1.16 {is command with object argument
+} -setup $setup3 -body {
+ itcl::is object -foo
+} -cleanup $cleanup -result 1
+
+test basic-1.17 {is command with object argument (object does not exist)
+} -body {
+ itcl::is object xxx
+} -result 0
+
+test basic-1.18 {is command with object argument (with code command)
+} -setup $setup3 -body {
+ itcl::is object [itcl::code -- -foo]
+} -cleanup $cleanup -result 1
+
+test basic-1.19 {classes can be unicode
+} -body {
+ itcl::class \u6210bcd { method foo args { return "bar" } }
+ \u6210bcd #auto
+} -result "\u6210bcd0"
+
+test basic-1.20 {
+ classes can be unicode
+} -body {
+ \u6210bcd0 foo
+} -cleanup {
+ ::itcl::delete class \u6210bcd
+} -result {bar}
+
+test basic-1.21 {error on empty class name
+} -body {
+ itcl::class {} {}
+} -returnCodes error -result {invalid class name ""}
+
+test basic-1.22 {error on empty object name
+} -setup {
+ itcl::class ::A {}
+} -body {
+ ::A {}
+} -cleanup {
+ ::itcl::delete class ::A
+} -returnCodes error -result {object name must not be empty}
+
+# ----------------------------------------------------------------------
+# #auto names
+# ----------------------------------------------------------------------
+test basic-2.1 {create an object with an automatic name
+} -setup $setup -body {
+ Counter #auto
+} -cleanup $cleanup -result {counter0}
+
+test basic-2.2 {bury "#auto" within object name
+} -setup $setup -body {
+ Counter x#autoy
+} -cleanup $cleanup -result {xcounter0y}
+
+test basic-2.3 {bury "#auto" within object name
+} -setup $setup -body {
+ Counter a#aut#autob
+} -cleanup $cleanup -result {a#autcounter0b}
+
+test basic-2.4 {"#auto" is smart enough to skip names that are taken
+} -setup $setup -body {
+ Counter counter3
+ Counter #auto
+} -cleanup $cleanup -result {counter0}
+
+test basic-2.5 {"#auto" with :: at front of name
+} -body {
+ itcl::class AutoCheck {}
+ set result [AutoCheck ::#auto]
+ rename AutoCheck {}
+ set result
+} -result {::autoCheck0}
+
+test basic-2.6 {"#auto" with :: at front of name inside method
+} -body {
+ itcl::class AutoCheck {
+ proc new {} {
+ return [AutoCheck ::#auto]
+ }
+ }
+ set result [AutoCheck::new]
+ rename AutoCheck {}
+ set result
+} -result {::autoCheck0}
+
+test basic-2.7 {"#auto" with :: at front of name inside method inside namespace
+} -body {
+ namespace eval AutoCheckNs {}
+ itcl::class AutoCheckNs::AutoCheck {
+ proc new {} {
+ return [AutoCheckNs::AutoCheck ::#auto]
+ }
+ }
+ set result [AutoCheckNs::AutoCheck::new]
+ namespace delete AutoCheckNs
+ set result
+} -cleanup {
+ namespace delete ::itcl::internal::variables::AutoCheckNs
+} -result {::autoCheck0}
+
+test basic-3.1 {object access command works
+} -setup $setup4 -body {
+ list [c ++] [c ++] [c ++]
+} -cleanup $cleanup -result {1 2 3}
+
+test basic-3.2 {errors produce usage info
+} -setup $setup4 -body {
+ list [catch "c xyzzy" msg] $msg
+} -cleanup $cleanup -result {1 {bad option "xyzzy": should be one of...
+ c ++
+ c cget -option
+ c configure ?-option? ?value -option value...?
+ c isa className}}
+
+test basic-3.3 {built-in configure can query public variables
+} -setup $setup4 -body {
+ c configure
+} -cleanup $cleanup -result {{-by 1 1}}
+
+test basic-3.4 {built-in configure can query one public variable
+} -setup $setup4 -body {
+ c configure -by
+} -cleanup $cleanup -result {-by 1 1}
+
+test basic-3.5 {built-in configure can set public variable
+} -setup $setup4 -body {
+ list [c configure -by 2] [c cget -by]
+} -cleanup $cleanup -result {{} 2}
+
+test basic-3.6 {configure actually changes public variable
+} -setup $setup4 -body {
+ list [c ++] [c ++]
+} -cleanup $cleanup -result {1 2}
+
+test basic-3.7 {class procs can be accessed
+} -setup $setup -body {
+ Counter::num
+} -cleanup $cleanup -result 0
+
+test basic-3.8 {obsolete syntax is no longer allowed
+} -setup $setup -body {
+ list [catch "Counter :: num" msg] $msg
+} -cleanup $cleanup -result {1 {syntax "class :: proc" is an anachronism
+[incr Tcl] no longer supports this syntax.
+Instead, remove the spaces from your procedure invocations:
+ Counter::num ?args?}}
+
+
+# ----------------------------------------------------------------------
+# Classes can be destroyed and redefined
+# ----------------------------------------------------------------------
+test basic-4.1 {classes can be destroyed
+} -setup $setup -body {
+ list [itcl::delete class Counter] \
+ [itcl::find classes Counter] \
+ [namespace children :: Counter] \
+ [namespace which -command Counter]
+} -result {{} {} {} {}}
+
+test basic-4.2 {classes can be redefined
+} -body {
+ itcl::class Counter {
+ method ++ {} {
+ return [incr val $by]
+ }
+ public variable by 1
+ protected variable val 0
+ }
+} -result {}
+
+test basic-4.3 {the redefined class is actually different
+} -body {
+ list [catch "Counter::num" msg] $msg
+} -result {1 {invalid command name "Counter::num"}}
+
+test basic-4.4 {objects can be created from the new class
+} -body {
+ list [Counter #auto] [Counter #auto]
+} -result {counter0 counter1}
+
+test basic-4.5 {namespaces for #auto are prepended to the command name
+} -body {
+ namespace eval someNS1 {}
+ namespace eval someNS2 {}
+ list [Counter someNS1::#auto] [Counter someNS2::#auto]
+} -cleanup {
+ ::itcl::delete object someNS1::counter2 someNS2::counter3
+} -result "[list someNS1::counter2 someNS2::counter3]"
+
+test basic-4.6 {when a class is destroyed, its objects are deleted
+} -body {
+ list [lsort [itcl::find objects counter*]] \
+ [itcl::delete class Counter] \
+ [lsort [itcl::find objects counter*]]
+} -result {{counter0 counter1} {} {}}
+
+check_itcl_basic_errors
+
+test basic-4.7 {clean-up of internal facilities
+} -setup $setup4 -body {
+ # check callbacks are called if class gets removed using all possible ways:
+ # objects are properly destroyed,
+ # callback removing the namespace for the common private and protected variables
+ # (in ITCL_VARIABLES_NAMESPACE) is called, etc
+ set ::tcltest::itcl_basic_errors {}
+ set ivns ::itcl::internal::variables[namespace which Counter]
+ set result {}
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ eval $cleanup
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ eval $setup4
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ rename Counter {}
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ eval $setup4
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ namespace delete Counter
+ lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+ lappend result {*}$::tcltest::itcl_basic_errors
+} -cleanup {
+ unset -nocomplain ivns ::tcltest::itcl_basic_errors
+} -result [lrepeat 3 1 1 0 0]
+
+# ----------------------------------------------------------------------
+# Namespace variables
+# ----------------------------------------------------------------------
+test basic-5.1 {define a simple class with variables in the namespace
+} -body {
+ itcl::class test_globals {
+ common g1 "global1"
+ proc getval {name} {
+ variable $name
+ return [set [namespace tail $name]]
+ }
+ proc setval {name val} {
+ variable $name
+ return [set [namespace tail $name] $val]
+ }
+ method do {args} {
+ return [eval $args]
+ }
+ }
+ namespace eval test_globals {
+ variable g2 "global2"
+ }
+} -result {}
+
+test basic-5.2 {create an object for the tests
+} -body {
+ test_globals #auto
+} -result {test_globals0}
+
+test basic-5.3 {common variables live in the namespace
+} -body {
+ lsort [info vars ::test_globals::*]
+} -result {::test_globals::g1 ::test_globals::g2}
+
+test basic-5.4 {common variables can be referenced transparently
+} -body {
+ list [catch {test_globals0 do set g1} msg] $msg
+} -result {0 global1}
+
+test basic-5.5 {namespace variables require a declaration
+} -body {
+ list [catch {test_globals0 do set g2} msg] $msg
+} -result {1 {can't read "g2": no such variable}}
+
+test basic-5.6a {variable accesses variables within namespace
+} -body {
+ list [catch {test_globals::getval g1} msg] $msg
+} -result {0 global1}
+
+test basic-5.6b {variable accesses variables within namespace
+} -body {
+ list [catch {test_globals::getval g2} msg] $msg
+} -result {0 global2}
+
+test basic-5.7 {variable command will not find vars in other namespaces
+} -body {
+ set ::test_global_0 "g0"
+ list [catch {test_globals::getval test_global_0} msg] $msg \
+ [catch {test_globals::getval ::test_global_0} msg] $msg \
+} -result {1 {can't read "test_global_0": no such variable} 0 g0}
+
+test basic-5.8 {to create globals in a namespace, use the full path
+} -body {
+ test_globals::setval ::test_global_1 g1
+ namespace eval :: {lsort [info globals test_global_*]}
+} -result {test_global_0 test_global_1}
+
+test basic-5.9 {variable names can have ":" in them
+} -body {
+ test_globals::setval ::test:global:2 g2
+ namespace eval :: {info globals test:global:2}
+} -result {test:global:2}
+
+if {[namespace which [namespace current]::test_globals] ne {}} {
+ ::itcl::delete class test_globals
+}
+
+
+
+# ----------------------------------------------------------------------
+# Array variables
+# ----------------------------------------------------------------------
+test basic-6.1 {set up a class definition with array variables
+} -body {
+ proc test_arrays_get {name} {
+ upvar $name x
+ set rlist {}
+ foreach index [lsort [array names x]] {
+ lappend rlist [list $index $x($index)]
+ }
+ return $rlist
+ }
+ itcl::class test_arrays {
+ variable nums
+ common undefined
+
+ common colors
+ set colors(red) #ff0000
+ set colors(green) #00ff00
+ set colors(blue) #0000ff
+
+ constructor {} {
+ set nums(one) 1
+ set nums(two) 2
+ set nums(three) 3
+
+ set undefined(a) A
+ set undefined(b) B
+ }
+ method do {args} {
+ return [eval $args]
+ }
+ }
+ test_arrays #auto
+} -result {test_arrays0}
+
+test basic-6.2 {test array access for instance variables
+} -body {
+ lsort [test_arrays0 do array get nums]
+} -result {1 2 3 one three two}
+
+test basic-6.3 {test array access for commons
+} -body {
+ lsort [test_arrays0 do array get colors]
+} -result [list #0000ff #00ff00 #ff0000 blue green red]
+
+test basic-6.4 {test array access for instance variables via "upvar"
+} -body {
+ test_arrays0 do test_arrays_get nums
+} -result {{one 1} {three 3} {two 2}}
+
+test basic-6.5 {test array access for commons via "upvar"
+} -body {
+ test_arrays0 do test_arrays_get colors
+} -result {{blue #0000ff} {green #00ff00} {red #ff0000}}
+
+test basic-6.6a {test array access for commons defined in constructor
+} -body {
+ lsort [test_arrays0 do array get undefined]
+} -result {A B a b}
+
+test basic-6.6b {test array access for commons defined in constructor
+} -body {
+ test_arrays0 do test_arrays_get undefined
+} -result {{a A} {b B}}
+
+test basic-6.6c {test array access for commons defined in constructor
+} -body {
+ list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]
+} -result {A B}
+
+test basic-6.7 {common variables can be unset
+} -body {
+ test_arrays0 do unset undefined
+ test_arrays0 do array names undefined
+} -result {}
+
+test basic-6.8 {common variables can be redefined
+} -body {
+ test_arrays0 do set undefined "scalar"
+} -result {scalar}
+
+proc testVarResolver {{access private} {init 0}} {
+ eval [string map [list \$access $access \$init $init] {
+ itcl::class A {
+ $access common cv "A::cv"
+ public proc cv {} {set cv}
+ }
+ itcl::class B {
+ inherit A
+ public common res {}
+ lappend res [info exists cv]
+ if {$init} {
+ $access common cv ""
+ } else {
+ $access common cv
+ }
+ lappend res [info exists cv]
+ lappend cv "B::cv-add"
+ public proc cv {} {set cv}
+ }
+ lappend B::res [A::cv] [B::cv]
+ set B::res
+ }]
+}
+test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
+ # private uninitialized var:
+ testVarResolver private 0
+} -result {0 0 A::cv B::cv-add} -cleanup {
+ itcl::delete class B A
+}
+test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
+ # public uninitialized var:
+ testVarResolver public 0
+} -result {1 0 A::cv B::cv-add} -cleanup {
+ itcl::delete class B A
+}
+test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
+ # private initialized var:
+ testVarResolver private 1
+} -result {0 1 A::cv B::cv-add} -cleanup {
+ itcl::delete class B A
+}
+test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
+ # public initialized var:
+ testVarResolver public 1
+} -result {1 1 A::cv B::cv-add} -cleanup {
+ itcl::delete class B A
+}
+
+if {[namespace which test_arrays] ne {}} {
+ ::itcl::delete class test_arrays
+}
+check_itcl_basic_errors
+rename check_itcl_basic_errors {}
+
+::tcltest::cleanupTests
+return
OSDN Git Service
