itcl/itcl/tests/old/basic.test

   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$
  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 # ----------------------------------------------------------------------
  19 foreach obj [itcl_info objects -class Foo] {
  20         $obj delete
  21 }
  22
  23 # ----------------------------------------------------------------------
  24 #  CREATING OBJECTS
  25 # ----------------------------------------------------------------------
  26 test {Create a simple object} {
  27         Foo x
  28 } {
  29         $result == "x"
  30 }
  31
  32 test {Make sure that object names cannot be duplicated} {
  33         catch "Foo x" errmsg
  34 } {
  35         $result == 1
  36 }
  37
  38 test {Create another object} {
  39         Foo xx
  40 } {
  41         $result == "xx"
  42 }
  43
  44 test {Create an object with an automatic name} {
  45         Foo #auto
  46 } {
  47         [string match foo* $result]
  48 }
  49
  50 test {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 # ----------------------------------------------------------------------
  59 test {Info: all public variables} {
  60         x info public
  61 } {
  62         [test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}]
  63 }
  64
  65 test {Info: public variable initial value} {
  66         x info public blit -init
  67 } {
  68         $result == ""
  69 }
  70
  71 test {Info: public variable initial value (undefined)} {
  72         x info public blit -value
  73 } {
  74         $result == "<undefined>"
  75 }
  76
  77 test {Info: public variable initial value} {
  78         x info public blat -init
  79 } {
  80         $result == 0
  81 }
  82
  83 test {Info: public variable current value} {
  84         x info public blot -value
  85 } {
  86         $result == 1
  87 }
  88
  89 test {Info: public variable config statement} {
  90         x info public blit -config
  91 } {
  92         $result == ""
  93 }
  94
  95 test {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 # ----------------------------------------------------------------------
 104 test {Setting public variables via "config"} {
 105         x config -blit 27 -blat xyz
 106 } {
 107         $result == "Foo::blit Foo::blat"
 108 }
 109
 110 test {Info: public variable init/current value} {
 111         x info public blit -init -value
 112 } {
 113         $result == {{} 27}
 114 }
 115
 116 test {Info: public variable init/current value} {
 117         x info public blat -init -value
 118 } {
 119         $result == {0 xyz}
 120 }
 121
 122 test {"config" is ordinary arg if it is not last arg} {
 123         x configx -blit pdq
 124 } {
 125         $result == {-blit|pdq}
 126 }
 127
 128 test {Public variables with "config" code} {
 129         set WATCH ""
 130         concat [x config -blot abc] / $WATCH
 131 } {
 132         $result == "Foo::blot / blot=abc"
 133 }
 134
 135 test {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 # ----------------------------------------------------------------------
 146 test {Info: all protected variables} {
 147         x info protected
 148 } {
 149         [test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}]
 150 }
 151
 152 test {Info: protected "this" variable} {
 153         x info protected this -value
 154 } {
 155         $result == "::x"
 156 }
 157
 158 test {Info: protected "this" variable} {
 159         xx info protected this -value
 160 } {
 161         $result == "::xx"
 162 }
 163
 164 test {Info: protected variable initial value} {
 165         x info protected _blit -init
 166 } {
 167         $result == ""
 168 }
 169
 170 test {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 # ----------------------------------------------------------------------
 180 test {Info: all protected variables} {
 181         x info common
 182 } {
 183         [test_cmp_lists $result {Foo::foos Foo::nfoo}]
 184 }
 185
 186 test {Info: common variable initial value} {
 187         x info common foos -init
 188 } {
 189         $result == ""
 190 }
 191
 192 test {Info: common variable initial value} {
 193         x info common nfoo -init
 194 } {
 195         $result == 0
 196 }
 197
 198 test {Info: common variable access/value} {
 199         x do {set nfoo 999}
 200         x info common nfoo -value
 201 } {
 202         $result == 999
 203 }
 204
 205 test {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
 212 test {Access common data in proc} {
 213         x do {set nfoo 10}
 214         Foo :: nfoos
 215 } {
 216         $result == 10
 217 }
 218
 219 test {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
 225 test {Arrays as common data} {
 226         Foo :: foos
 227 } {
 228         [test_cmp_lists $result [itcl_info objects -class Foo]]
 229 }
 230
 231 # ----------------------------------------------------------------------
 232 #  METHODS
 233 # ----------------------------------------------------------------------
 234 test {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
 246 test {Info: method args} {
 247         x info method nothing -args
 248 } {
 249         $result == ""
 250 }
 251
 252 test {Info: method args} {
 253         x info method xconfig -args
 254 } {
 255         $result == "x config"
 256 }
 257
 258 test {Info: method body} {
 259         x info method nothing -body
 260 } {
 261         $result == ""
 262 }
 263
 264 test {Info: method body} {
 265         x info method xconfig -body
 266 } {
 267         $result == {
 268                 return "$x|$config"
 269         }
 270 }
 271
 272 # ----------------------------------------------------------------------
 273 #  PROCS
 274 # ----------------------------------------------------------------------
 275 test {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
 283 test {Info: proc args} {
 284         x info proc nfoos -args
 285 } {
 286         $result == ""
 287 }
 288
 289 test {Info: proc args} {
 290         x info proc foos -args
 291 } {
 292         $result == "{pattern *}"
 293 }
 294
 295 test {Info: proc body} {
 296         x info proc nfoos -body
 297 } {
 298         $result == {
 299                 return $nfoo
 300         }
 301 }
 302
 303 test {Info: proc body} {
 304         x info body nfoos
 305 } {
 306         $result == {
 307                 return $nfoo
 308         }
 309 }
 310
 311 # ----------------------------------------------------------------------
 312 #  ARGUMENT LISTS
 313 # ----------------------------------------------------------------------
 314 test {Default arguments can get assigned a proper value} {
 315         Foo :: foos x*
 316 } {
 317         [test_cmp_lists $result {x xx}]
 318 }
 319
 320 test {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
 328 test {"args" formal argument absorbs extra arguments} {
 329         Foo :: echo abc 1 2 3
 330 } {
 331         $result == "abc | 3: 1 2 3"
 332 }
 333
 334 test {"args" formal argument absorbs extra arguments} {
 335         Foo :: echo def
 336 } {
 337         $result == "def | 0: "
 338 }
 339
 340 test {"args" formal argument absorbs extra arguments} {
 341         x xecho abc 1 2 3
 342 } {
 343         $result == "abc | 3: 1 2 3"
 344 }
 345
 346 test {"args" formal argument absorbs extra arguments} {
 347         x xecho def
 348 } {
 349         $result == "def | 0: "
 350 }
 351
 352 test {Extra args cause an error} {
 353         catch "x configx arg arg error"
 354 } {
 355         $result != 0
 356 }
 357
 358 test {Extra args cause an error} {
 359         catch "x nothing error"
 360 } {
 361         $result != 0
 362 }
 363
 364 test {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
 376 test {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 # ----------------------------------------------------------------------
 386 test {Delete an object} {
 387         x delete
 388 } {
 389         $result == ""
 390 }
 391
 392 test {Delete an object} {
 393         xx delete
 394 } {
 395         $result == ""
 396 }
 397
 398 test {Destructor is properly invoked} {
 399         Foo :: foos
 400 } {
 401         [test_cmp_lists $result [itcl_info objects -class Foo]]
 402 }
 403
 404 test {Object names are removed as commands} {
 405         expr {[info commands x] == "" && [info commands xx] == ""}
 406 } {
 407         $result == 1
 408 }