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.1 1998/07/27 18:41:24 stanton 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 16# ---------------------------------------------------------------------- 17# CLEAN THE SLATE 18# ---------------------------------------------------------------------- 19foreach obj [itcl_info objects -class Foo] { 20 $obj delete 21} 22 23# ---------------------------------------------------------------------- 24# CREATING OBJECTS 25# ---------------------------------------------------------------------- 26test {Create a simple object} { 27 Foo x 28} { 29 $result == "x" 30} 31 32test {Make sure that object names cannot be duplicated} { 33 catch "Foo x" errmsg 34} { 35 $result == 1 36} 37 38test {Create another object} { 39 Foo xx 40} { 41 $result == "xx" 42} 43 44test {Create an object with an automatic name} { 45 Foo #auto 46} { 47 [string match foo* $result] 48} 49 50test {Get list of objects in a class} { 51 itcl_info objects -class Foo 52} { 53 [llength $result] == 3 54} 55 56# ---------------------------------------------------------------------- 57# PUBLIC VARIABLES 58# ---------------------------------------------------------------------- 59test {Info: all public variables} { 60 x info public 61} { 62 [test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}] 63} 64 65test {Info: public variable initial value} { 66 x info public blit -init 67} { 68 $result == "" 69} 70 71test {Info: public variable initial value (undefined)} { 72 x info public blit -value 73} { 74 $result == "<undefined>" 75} 76 77test {Info: public variable initial value} { 78 x info public blat -init 79} { 80 $result == 0 81} 82 83test {Info: public variable current value} { 84 x info public blot -value 85} { 86 $result == 1 87} 88 89test {Info: public variable config statement} { 90 x info public blit -config 91} { 92 $result == "" 93} 94 95test {Info: public variable config statement} { 96 x info public blot -config 97} { 98 $result == {global WATCH; set WATCH "blot=$blot"} 99} 100 101# ---------------------------------------------------------------------- 102# CONFIG-ING PUBLIC VARIABLES 103# ---------------------------------------------------------------------- 104test {Setting public variables via "config"} { 105 x config -blit 27 -blat xyz 106} { 107 $result == "Foo::blit Foo::blat" 108} 109 110test {Info: public variable init/current value} { 111 x info public blit -init -value 112} { 113 $result == {{} 27} 114} 115 116test {Info: public variable init/current value} { 117 x info public blat -init -value 118} { 119 $result == {0 xyz} 120} 121 122test {"config" is ordinary arg if it is not last arg} { 123 x configx -blit pdq 124} { 125 $result == {-blit|pdq} 126} 127 128test {Public variables with "config" code} { 129 set WATCH "" 130 concat [x config -blot abc] / $WATCH 131} { 132 $result == "Foo::blot / blot=abc" 133} 134 135test {Make sure object data is local to objects} { 136 x config -blit abc 137 xx config -blit xyz 138 concat [x info public blit -value] / [xx info public blit -value] 139} { 140 $result == "abc / xyz" 141} 142 143# ---------------------------------------------------------------------- 144# PROTECTED VARIABLES 145# ---------------------------------------------------------------------- 146test {Info: all protected variables} { 147 x info protected 148} { 149 [test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}] 150} 151 152test {Info: protected "this" variable} { 153 x info protected this -value 154} { 155 $result == "::x" 156} 157 158test {Info: protected "this" variable} { 159 xx info protected this -value 160} { 161 $result == "::xx" 162} 163 164test {Info: protected variable initial value} { 165 x info protected _blit -init 166} { 167 $result == "" 168} 169 170test {Info: protected variable access/value} { 171 x do {set _blit rst} 172} { 173 $result == "Foo says 'rst'" && 174 [x info protected _blit -value] == "rst" 175} 176 177# ---------------------------------------------------------------------- 178# COMMON VARIABLES 179# ---------------------------------------------------------------------- 180test {Info: all protected variables} { 181 x info common 182} { 183 [test_cmp_lists $result {Foo::foos Foo::nfoo}] 184} 185 186test {Info: common variable initial value} { 187 x info common foos -init 188} { 189 $result == "" 190} 191 192test {Info: common variable initial value} { 193 x info common nfoo -init 194} { 195 $result == 0 196} 197 198test {Info: common variable access/value} { 199 x do {set nfoo 999} 200 x info common nfoo -value 201} { 202 $result == 999 203} 204 205test {Make sure common data is really common} { 206 x do {set nfoo 0} 207 x info common nfoo -value 208} { 209 $result == [xx info common nfoo -value] 210} 211 212test {Access common data in proc} { 213 x do {set nfoo 10} 214 Foo :: nfoos 215} { 216 $result == 10 217} 218 219test {Common variables can be initialized within class definition} { 220 x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}} 221} { 222 $result == "Foo says 'foos-is-now-an-array'" 223} 224 225test {Arrays as common data} { 226 Foo :: foos 227} { 228 [test_cmp_lists $result [itcl_info objects -class Foo]] 229} 230 231# ---------------------------------------------------------------------- 232# METHODS 233# ---------------------------------------------------------------------- 234test {Info: all methods} { 235 x info method 236} { 237 [test_cmp_lists $result { 238 Foo::constructor Foo::destructor 239 Foo::nothing Foo::do Foo::xecho 240 Foo::config Foo::xconfig Foo::configx 241 Foo::testMethodArgs 242 Foo::configure Foo::delete Foo::cget Foo::isa 243 }] 244} 245 246test {Info: method args} { 247 x info method nothing -args 248} { 249 $result == "" 250} 251 252test {Info: method args} { 253 x info method xconfig -args 254} { 255 $result == "x config" 256} 257 258test {Info: method body} { 259 x info method nothing -body 260} { 261 $result == "" 262} 263 264test {Info: method body} { 265 x info method xconfig -body 266} { 267 $result == { 268 return "$x|$config" 269 } 270} 271 272# ---------------------------------------------------------------------- 273# PROCS 274# ---------------------------------------------------------------------- 275test {Info: all procs} { 276 x info proc 277} { 278 [test_cmp_lists $result { 279 Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs 280 }] 281} 282 283test {Info: proc args} { 284 x info proc nfoos -args 285} { 286 $result == "" 287} 288 289test {Info: proc args} { 290 x info proc foos -args 291} { 292 $result == "{pattern *}" 293} 294 295test {Info: proc body} { 296 x info proc nfoos -body 297} { 298 $result == { 299 return $nfoo 300 } 301} 302 303test {Info: proc body} { 304 x info body nfoos 305} { 306 $result == { 307 return $nfoo 308 } 309} 310 311# ---------------------------------------------------------------------- 312# ARGUMENT LISTS 313# ---------------------------------------------------------------------- 314test {Default arguments can get assigned a proper value} { 315 Foo :: foos x* 316} { 317 [test_cmp_lists $result {x xx}] 318} 319 320test {Default value for "config" argument} { 321 x config 322} { 323 $result == "Foo::blit Foo::blat" && 324 [x info public blit -value] == "auto" && 325 [x info public blat -value] == "matic" 326} 327 328test {"args" formal argument absorbs extra arguments} { 329 Foo :: echo abc 1 2 3 330} { 331 $result == "abc | 3: 1 2 3" 332} 333 334test {"args" formal argument absorbs extra arguments} { 335 Foo :: echo def 336} { 337 $result == "def | 0: " 338} 339 340test {"args" formal argument absorbs extra arguments} { 341 x xecho abc 1 2 3 342} { 343 $result == "abc | 3: 1 2 3" 344} 345 346test {"args" formal argument absorbs extra arguments} { 347 x xecho def 348} { 349 $result == "def | 0: " 350} 351 352test {Extra args cause an error} { 353 catch "x configx arg arg error" 354} { 355 $result != 0 356} 357 358test {Extra args cause an error} { 359 catch "x nothing error" 360} { 361 $result != 0 362} 363 364test {Formal arguments don't clobber public/protected variables} { 365 x do { 366 set blit okay 367 set _blit no-problem 368 } 369 x testMethodArgs yuck puke etc. 370} { 371 $result == "yuck, puke, and 1 other args" && 372 [x info public blit -value] == "okay" && 373 [x info protected _blit -value] == "no-problem" 374} 375 376test {Formal arguments don't clobber common variables} { 377 Foo :: testProcArgs yuck etc. 378} { 379 $result == "yuck, and 1 other args" && 380 [x info common nfoo -value] != "yuck" 381} 382 383# ---------------------------------------------------------------------- 384# DELETING OBJECTS 385# ---------------------------------------------------------------------- 386test {Delete an object} { 387 x delete 388} { 389 $result == "" 390} 391 392test {Delete an object} { 393 xx delete 394} { 395 $result == "" 396} 397 398test {Destructor is properly invoked} { 399 Foo :: foos 400} { 401 [test_cmp_lists $result [itcl_info objects -class Foo]] 402} 403 404test {Object names are removed as commands} { 405 expr {[info commands x] == "" && [info commands xx] == ""} 406} { 407 $result == 1 408} 409