1# 2# Basic tests for class definition and method/proc access 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# RCS: $Id: basic.test,v 1.12 2007/07/03 20:46:44 hobbs Exp $ 10# ---------------------------------------------------------------------- 11# Copyright (c) 1993-1998 Lucent Technologies, Inc. 12# ====================================================================== 13# See the file "license.terms" for information on usage and 14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {[lsearch [namespace children] ::tcltest] == -1} { 17 package require tcltest 2.1 18 namespace import -force ::tcltest::test 19} 20 21::tcltest::loadTestedCommands 22 23test basic-1.0 {empty string as class name should fail but not crash} { 24 list [catch {itcl::class "" {}} err] $err 25} {1 {invalid class name ""}} 26 27# ---------------------------------------------------------------------- 28# Simple class definition 29# ---------------------------------------------------------------------- 30test basic-1.1 {define a simple class} { 31 itcl::class Counter { 32 constructor {args} { 33 incr num 34 eval configure $args 35 } 36 destructor { 37 incr num -1 38 } 39 40 method ++ {} { 41 return [incr val $by] 42 } 43 proc num {} { 44 return $num 45 } 46 public variable by 1 47 protected variable val 0 48 private common num 0 49 } 50} "" 51 52test basic-1.2 {class is now defined} { 53 itcl::find classes Counter 54} {Counter} 55 56test basic-1.3 {access command exists with class name} { 57 namespace which -command Counter 58} {::Counter} 59 60test basic-1.4 {create a simple object} { 61 Counter x 62} {x} 63 64test basic-1.5a {object names cannot be duplicated} { 65 list [catch "Counter x" msg] $msg 66} {1 {command "x" already exists in namespace "::"}} 67 68test basic-1.5b {built-in commands cannot be clobbered} { 69 list [catch "Counter info" msg] $msg 70} {1 {command "info" already exists in namespace "::"}} 71 72test basic-1.6 {objects have an access command} { 73 namespace which -command x 74} {::x} 75 76test basic-1.7a {objects are added to the master list} { 77 itcl::find objects x 78} {x} 79 80test basic-1.7b {objects are added to the master list} { 81 itcl::find objects -class Counter x 82} {x} 83 84test basic-1.8 {objects can be deleted} { 85 list [itcl::delete object x] [namespace which -command x] 86} {{} {}} 87 88test basic-1.9 {objects can be recreated with the same name} { 89 Counter x 90} {x} 91 92test basic-1.10 {objects can be destroyed by deleting their access command} { 93 rename ::x "" 94 itcl::find objects x 95} {} 96 97test basic-1.11 {find command supports object names starting with -} { 98 Counter -foo 99 itcl::find objects -class Counter -foo 100} {-foo} 101test basic-1.12 {is command with class argument} { 102 itcl::is class Counter 103} {1} 104 105test basic-1.13 {is command with class argument (global namespace)} { 106 itcl::is class ::Counter 107} {1} 108 109test basic-1.14 {is command with class argument (wrapped in code command)} { 110 itcl::is class [itcl::code Counter] 111} {1} 112 113test basic-1.15 {is command with class argument (class does not exist)} { 114 itcl::is class Count 115} {0} 116 117test basic-1.16 {is command with object argument} { 118 itcl::is object -foo 119} {1} 120 121test basic-1.17 {is command with object argument (object does not exist)} { 122 itcl::is object xxx 123} {0} 124 125test basic-1.18 {is command with object argument (with code command)} { 126 itcl::is object [itcl::code -- -foo] 127} {1} 128 129test basic-1.19 {classes can be unicode} { 130 itcl::class \u6210bcd { method foo args { return "bar" } } 131 \u6210bcd #auto 132} \u6210bcd0 133test basic-1.20 {classes can be unicode} { 134 \u6210bcd0 foo 135} bar 136 137# ---------------------------------------------------------------------- 138# #auto names 139# ---------------------------------------------------------------------- 140test basic-2.1 {create an object with an automatic name} { 141 Counter #auto 142} {counter0} 143 144test basic-2.2 {bury "#auto" within object name} { 145 Counter x#autoy 146} {xcounter1y} 147 148test basic-2.3 {bury "#auto" within object name} { 149 Counter a#aut#autob 150} {a#autcounter2b} 151 152test basic-2.4 {"#auto" is smart enough to skip names that are taken} { 153 Counter counter3 154 Counter #auto 155} {counter4} 156 157test basic-2.5 {"#auto" with :: at front of name} { 158 itcl::class AutoCheck {} 159 set result [AutoCheck ::#auto] 160 rename AutoCheck {} 161 set result 162} {::autoCheck0} 163 164test basic-2.6 {"#auto" with :: at front of name inside method} { 165 itcl::class AutoCheck { 166 proc new {} { 167 return [AutoCheck ::#auto] 168 } 169 } 170 set result [AutoCheck::new] 171 rename AutoCheck {} 172 set result 173} {::autoCheck0} 174 175test basic-2.7 {"#auto" with :: at front of name inside method inside namespace} { 176 namespace eval AutoCheckNs {} 177 itcl::class AutoCheckNs::AutoCheck { 178 proc new {} { 179 return [AutoCheckNs::AutoCheck ::#auto] 180 } 181 } 182 set result [AutoCheckNs::AutoCheck::new] 183 namespace delete AutoCheckNs 184 set result 185} {::autoCheck0} 186 187# ---------------------------------------------------------------------- 188# Simple object use 189# ---------------------------------------------------------------------- 190test basic-3.1 {object access command works} { 191 Counter c 192 list [c ++] [c ++] [c ++] 193} {1 2 3} 194 195test basic-3.2 {errors produce usage info} { 196 list [catch "c xyzzy" msg] $msg 197} {1 {bad option "xyzzy": should be one of... 198 c ++ 199 c cget -option 200 c configure ?-option? ?value -option value...? 201 c isa className}} 202 203test basic-3.3 {built-in configure can query public variables} { 204 c configure 205} {{-by 1 1}} 206 207test basic-3.4 {built-in configure can query one public variable} { 208 c configure -by 209} {-by 1 1} 210 211test basic-3.5 {built-in configure can set public variable} { 212 list [c configure -by 2] [c cget -by] 213} {{} 2} 214 215test basic-3.6 {configure actually changes public variable} { 216 list [c ++] [c ++] 217} {5 7} 218 219test basic-3.7 {class procs can be accessed} { 220 Counter::num 221} {7} 222 223test basic-3.8 {obsolete syntax is no longer allowed} { 224 list [catch "Counter :: num" msg] $msg 225} {1 {syntax "class :: proc" is an anachronism 226[incr Tcl] no longer supports this syntax. 227Instead, remove the spaces from your procedure invocations: 228 Counter::num ?args?}} 229 230# ---------------------------------------------------------------------- 231# Classes can be destroyed and redefined 232# ---------------------------------------------------------------------- 233test basic-4.1 {classes can be destroyed} { 234 list [itcl::delete class Counter] \ 235 [itcl::find classes Counter] \ 236 [namespace children :: Counter] \ 237 [namespace which -command Counter] 238} {{} {} {} {}} 239 240test basic-4.2 {classes can be redefined} { 241 itcl::class Counter { 242 method ++ {} { 243 return [incr val $by] 244 } 245 public variable by 1 246 protected variable val 0 247 } 248} {} 249 250test basic-4.3 {the redefined class is actually different} { 251 list [catch "Counter::num" msg] $msg 252} {1 {invalid command name "Counter::num"}} 253 254test basic-4.4 {objects can be created from the new class} { 255 list [Counter #auto] [Counter #auto] 256} {counter0 counter1} 257 258test basic-4.5 {namespaces for #auto are prepended to the command name} { 259 namespace eval someNS1 {} 260 namespace eval someNS2 {} 261 list [Counter someNS1::#auto] [Counter someNS2::#auto] 262} [list someNS1::counter2 someNS2::counter3] 263 264test basic-4.6 {when a class is destroyed, its objects are deleted} { 265 list [lsort [itcl::find objects counter*]] \ 266 [itcl::delete class Counter] \ 267 [lsort [itcl::find objects counter*]] 268} {{counter0 counter1} {} {}} 269 270# ---------------------------------------------------------------------- 271# Namespace variables 272# ---------------------------------------------------------------------- 273test basic-5.1 {define a simple class with variables in the namespace} { 274 itcl::class test_globals { 275 common g1 "global1" 276 proc getval {name} { 277 variable $name 278 return [set [namespace tail $name]] 279 } 280 proc setval {name val} { 281 variable $name 282 return [set [namespace tail $name] $val] 283 } 284 method do {args} { 285 return [eval $args] 286 } 287 } 288 namespace eval test_globals { 289 variable g2 "global2" 290 } 291} "" 292 293test basic-5.2 {create an object for the tests} { 294 test_globals #auto 295} {test_globals0} 296 297test basic-5.3 {common variables live in the namespace} { 298 lsort [info vars ::test_globals::*] 299} {::test_globals::g1 ::test_globals::g2} 300 301test basic-5.4 {common variables can be referenced transparently} { 302 list [catch {test_globals0 do set g1} msg] $msg 303} {0 global1} 304 305test basic-5.5 {namespace variables require a declaration} { 306 list [catch {test_globals0 do set g2} msg] $msg 307} {1 {can't read "g2": no such variable}} 308 309test basic-5.6a {variable accesses variables within namespace} { 310 list [catch {test_globals::getval g1} msg] $msg 311} {0 global1} 312 313test basic-5.6a {variable accesses variables within namespace} { 314 list [catch {test_globals::getval g2} msg] $msg 315} {0 global2} 316 317test basic-5.7 {variable command will not find vars in other namespaces} { 318 set ::test_global_0 "g0" 319 list [catch {test_globals::getval test_global_0} msg] $msg \ 320 [catch {test_globals::getval ::test_global_0} msg] $msg \ 321} {1 {can't read "test_global_0": no such variable} 0 g0} 322 323test basic-5.8 {to create globals in a namespace, use the full path} { 324 test_globals::setval ::test_global_1 g1 325 namespace eval :: {lsort [info globals test_global_*]} 326} {test_global_0 test_global_1} 327 328test basic-5.9 {variable names can have ":" in them} { 329 test_globals::setval ::test:global:2 g2 330 namespace eval :: {info globals test:global:2} 331} {test:global:2} 332 333# ---------------------------------------------------------------------- 334# Array variables 335# ---------------------------------------------------------------------- 336test basic-6.1 {set up a class definition with array variables} { 337 proc test_arrays_get {name} { 338 upvar $name x 339 set rlist {} 340 foreach index [lsort [array names x]] { 341 lappend rlist [list $index $x($index)] 342 } 343 return $rlist 344 } 345 itcl::class test_arrays { 346 variable nums 347 common undefined 348 349 common colors 350 set colors(red) #ff0000 351 set colors(green) #00ff00 352 set colors(blue) #0000ff 353 354 constructor {} { 355 set nums(one) 1 356 set nums(two) 2 357 set nums(three) 3 358 359 set undefined(a) A 360 set undefined(b) B 361 } 362 method do {args} { 363 return [eval $args] 364 } 365 } 366 test_arrays #auto 367} {test_arrays0} 368 369test basic-6.2 {test array access for instance variables} { 370 lsort [test_arrays0 do array get nums] 371} {1 2 3 one three two} 372 373test basic-6.3 {test array access for commons} { 374 lsort [test_arrays0 do array get colors] 375} [list #0000ff #00ff00 #ff0000 blue green red] 376 377test basic-6.4 {test array access for instance variables via "upvar"} { 378 test_arrays0 do test_arrays_get nums 379} {{one 1} {three 3} {two 2}} 380 381test basic-6.5 {test array access for commons via "upvar"} { 382 test_arrays0 do test_arrays_get colors 383} {{blue #0000ff} {green #00ff00} {red #ff0000}} 384 385test basic-6.6a {test array access for commons defined in constructor} { 386 lsort [test_arrays0 do array get undefined] 387} {A B a b} 388 389test basic-6.6b {test array access for commons defined in constructor} { 390 test_arrays0 do test_arrays_get undefined 391} {{a A} {b B}} 392 393test basic-6.6c {test array access for commons defined in constructor} { 394 list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)] 395} {A B} 396 397test basic-6.7 {common variables can be unset} { 398 test_arrays0 do unset undefined 399 test_arrays0 do array names undefined 400} {} 401 402test basic-6.8 {common variables can be redefined} { 403 test_arrays0 do set undefined "scalar" 404} {scalar} 405 406::tcltest::cleanupTests 407return 408