1# This file contains a collection of tests for functionality originally 2# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs 3# the tests and generates output for errors. No output means no errors were 4# found. 5# 6# Copyright © 2014-2016 Andreas Kupries 7# Copyright © 2018 Donal K. Fellows 8# 9# See the file "license.terms" for information on usage and redistribution of 10# this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12package require tcl::oo 1.0.3 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18test ooUtil-1.1 {TIP 478: classmethod} -setup { 19 oo::class create parent 20} -body { 21 oo::class create ActiveRecord { 22 superclass parent 23 classmethod find args { 24 return "[self] called with arguments: $args" 25 } 26 } 27 oo::class create Table { 28 superclass ActiveRecord 29 } 30 Table find foo bar 31} -cleanup { 32 parent destroy 33} -result {::Table called with arguments: foo bar} 34test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { 35 namespace eval ::testns {} 36} -body { 37 namespace eval ::testns { 38 oo::class create ActiveRecord { 39 classmethod find args { 40 return "[self] called with arguments: $args" 41 } 42 } 43 oo::class create Table { 44 superclass ActiveRecord 45 } 46 } 47 testns::Table find foo bar 48} -cleanup { 49 namespace delete ::testns 50} -result {::testns::Table called with arguments: foo bar} 51test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { 52 oo::class create parent 53} -body { 54 oo::class create TestClass { 55 superclass oo::class parent 56 self method create {name ignore body} { 57 next $name $body 58 } 59 } 60 TestClass create okay {} {} 61} -cleanup { 62 parent destroy 63} -result {::okay} 64test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { 65 oo::class create parent 66} -body { 67 oo::class create ActiveRecord { 68 superclass parent 69 classmethod find args { 70 return "[self] called with arguments: $args" 71 } 72 } 73 oo::class create Table { 74 superclass ActiveRecord 75 } 76 oo::class create SubTable { 77 superclass Table 78 } 79 SubTable find foo bar 80} -cleanup { 81 parent destroy 82} -result {::SubTable called with arguments: foo bar} 83test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { 84 oo::class create parent 85} -body { 86 oo::class create ActiveRecord { 87 superclass parent 88 classmethod find args { 89 return "[self] called with arguments: $args" 90 } 91 } 92 oo::class create Table { 93 superclass ActiveRecord 94 } 95 set t [Table new] 96 $t find 1 2 3 97} -cleanup { 98 parent destroy 99} -result {::Table called with arguments: 1 2 3} 100test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { 101 oo::class create parent 102} -body { 103 oo::class create ActiveRecord { 104 superclass parent 105 classmethod find args { 106 return "[self] called with arguments: $args" 107 } 108 } 109 oo::class create Table { 110 superclass ActiveRecord 111 unexport find 112 } 113 set t [Table new] 114 $t find 1 2 3 115} -returnCodes error -cleanup { 116 parent destroy 117} -match glob -result {unknown method "find": must be *} 118test ooUtil-1.7 {} -setup { 119 oo::class create parent 120} -body { 121 oo::class create Foo { 122 superclass parent 123 classmethod bar {} { 124 puts "This is in the class; self is [self]" 125 my meee 126 } 127 classmethod meee {} { 128 puts "This is meee" 129 } 130 } 131 oo::class create Grill { 132 superclass Foo 133 classmethod meee {} { 134 puts "This is meee 2" 135 } 136 } 137 list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] 138} -cleanup { 139 parent destroy 140} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" 141# Two tests to confirm that we correctly initialise the scripted part of TclOO 142# in child interpreters. This is slightly tricky at the implementation level 143# because we cannot count on either [source] or [open] being available. 144test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { 145 set childinterp [interp create] 146} -body { 147 $childinterp eval { 148 oo::class create ActiveRecord { 149 classmethod find args { 150 return "[self] called with arguments: $args" 151 } 152 } 153 oo::class create Table { 154 superclass ActiveRecord 155 } 156 # This is confirming that this is not the parent interpreter 157 list [Table find foo bar] [info globals childinterp] 158 } 159} -cleanup { 160 interp delete $childinterp 161} -result {{::Table called with arguments: foo bar} {}} 162test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { 163 set safeinterp [interp create -safe] 164} -body { 165 $safeinterp eval { 166 oo::class create ActiveRecord { 167 classmethod find args { 168 return "[self] called with arguments: $args" 169 } 170 } 171 oo::class create Table { 172 superclass ActiveRecord 173 } 174 # This is confirming that this is a (basic) safe interpreter 175 list [Table find foo bar] [info commands source] 176 } 177} -cleanup { 178 interp delete $safeinterp 179} -result {{::Table called with arguments: foo bar} {}} 180 181test ooUtil-2.1 {TIP 478: callback generation} -setup { 182 oo::class create parent 183} -body { 184 oo::class create c { 185 superclass parent 186 method CallMe {} { return ok,[self] } 187 method makeCall {} { 188 return [callback CallMe] 189 } 190 } 191 c create ::context 192 set cb [context makeCall] 193 {*}$cb 194} -cleanup { 195 parent destroy 196} -result {ok,::context} 197test ooUtil-2.2 {TIP 478: callback generation} -setup { 198 oo::class create parent 199} -body { 200 oo::class create c { 201 superclass parent 202 method CallMe {a b c} { return ok,[self],$a,$b,$c } 203 method makeCall {b} { 204 return [callback CallMe 123 $b] 205 } 206 } 207 c create ::context 208 set cb [context makeCall "a b c"] 209 {*}$cb PQR 210} -cleanup { 211 parent destroy 212} -result {ok,::context,123,a b c,PQR} 213test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { 214 oo::class create parent 215} -body { 216 oo::class create c { 217 superclass parent 218 method CallMe {} { return ok,[self] } 219 method makeCall {} { 220 return [mymethod CallMe] 221 } 222 } 223 c create ::context 224 set cb [context makeCall] 225 {*}$cb 226} -cleanup { 227 parent destroy 228} -result {ok,::context} 229test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { 230 oo::class create parent 231} -body { 232 oo::class create c { 233 superclass parent 234 method CallMe {a b c} { return ok,[self],$a,$b,$c } 235 method makeCall {b} { 236 return [mymethod CallMe 123 $b] 237 } 238 } 239 c create ::context 240 set cb [context makeCall "a b c"] 241 {*}$cb PQR 242} -cleanup { 243 parent destroy 244} -result {ok,::context,123,a b c,PQR} 245test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { 246 oo::class create parent 247} -body { 248 oo::class create c { 249 superclass parent 250 method makeCall {b} { 251 return [callback CallMe 123 $b] 252 } 253 } 254 c create ::context 255 set cb [context makeCall "a b c"] 256 set result [list [catch {{*}$cb PQR} msg] $msg] 257 oo::objdefine context { 258 method CallMe {a b c} { return ok,[self],$a,$b,$c } 259 } 260 lappend result [{*}$cb PQR] 261} -cleanup { 262 parent destroy 263} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} 264test ooUtil-2.6 {TIP 478: callback use case} -setup { 265 oo::class create parent 266 unset -nocomplain x 267} -body { 268 oo::class create c { 269 superclass parent 270 variable count 271 constructor {var} { 272 set count 0 273 upvar 1 $var v 274 trace add variable v write [callback TraceCallback] 275 } 276 method count {} {return $count} 277 method TraceCallback {name1 name2 op} { 278 incr count 279 } 280 } 281 set o [c new x] 282 for {set x 0} {$x < 5} {incr x} {} 283 $o count 284} -cleanup { 285 unset -nocomplain x 286 parent destroy 287} -result 6 288 289test ooUtil-3.1 {TIP 478: class initialisation} -setup { 290 oo::class create parent 291 catch {rename ::foobar-3.1 {}} 292} -body { 293 oo::class create ::cls { 294 superclass parent 295 initialise { 296 proc foobar-3.1 {} {return ok} 297 } 298 method calls {} { 299 list [catch foobar-3.1 msg] $msg \ 300 [namespace eval [info object namespace [self class]] foobar-3.1] 301 } 302 } 303 [cls new] calls 304} -cleanup { 305 parent destroy 306} -result {1 {invalid command name "foobar-3.1"} ok} 307test ooUtil-3.2 {TIP 478: class variables} -setup { 308 oo::class create parent 309 catch {rename ::foobar-3.1 {}} 310} -body { 311 oo::class create ::cls { 312 superclass parent 313 initialise { 314 variable x 123 315 } 316 method call {} { 317 classvariable x 318 incr x 319 } 320 } 321 cls create a 322 cls create b 323 cls create c 324 list [a call] [b call] [c call] [a call] [b call] [c call] 325} -cleanup { 326 parent destroy 327} -result {124 125 126 127 128 129} 328test ooUtil-3.3 {TIP 478: class initialisation} -setup { 329 oo::class create parent 330 catch {rename ::foobar-3.3 {}} 331} -body { 332 oo::class create ::cls { 333 superclass parent 334 initialize { 335 proc foobar-3.3 {} {return ok} 336 } 337 method calls {} { 338 list [catch foobar-3.3 msg] $msg \ 339 [namespace eval [info object namespace [self class]] foobar-3.3] 340 } 341 } 342 [cls new] calls 343} -cleanup { 344 parent destroy 345} -result {1 {invalid command name "foobar-3.3"} ok} 346test ooUtil-3.4 {TIP 478: class initialisation} -setup { 347 oo::class create parent 348 catch {rename ::appendToResultVar {}} 349 proc ::appendToResultVar args { 350 lappend ::result {*}$args 351 } 352 set result {} 353} -body { 354 trace add execution oo::define::initialise enter appendToResultVar 355 oo::class create ::cls { 356 superclass parent 357 initialize {proc xyzzy {} {}} 358 } 359 return $result 360} -cleanup { 361 catch { 362 trace remove execution oo::define::initialise enter appendToResultVar 363 } 364 rename ::appendToResultVar {} 365 parent destroy 366} -result {{initialize {proc xyzzy {} {}}} enter} 367test ooUtil-3.5 {TIP 478: class initialisation} -body { 368 oo::define oo::object { 369 ::list [::namespace which initialise] [::namespace which initialize] \ 370 [::namespace origin initialise] [::namespace origin initialize] 371 } 372} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} 373 374test ooUtil-4.1 {TIP 478: singleton} -setup { 375 oo::class create parent 376} -body { 377 oo::singleton create xyz { 378 superclass parent 379 } 380 set x [xyz new] 381 set y [xyz new] 382 set z [xyz new] 383 set code [catch {$x destroy} msg] 384 set p [xyz new] 385 lappend code [catch {rename $x ""}] 386 set q [xyz new] 387 string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] 388} -cleanup { 389 parent destroy 390} -result {1 0 ONE ONE ONE ONE TWO TWO} 391test ooUtil-4.2 {TIP 478: singleton errors} -setup { 392 oo::class create parent 393} -body { 394 oo::singleton create xyz { 395 superclass parent 396 } 397 [xyz new] destroy 398} -returnCodes error -cleanup { 399 parent destroy 400} -result {may not destroy a singleton object} 401test ooUtil-4.3 {TIP 478: singleton errors} -setup { 402 oo::class create parent 403} -body { 404 oo::singleton create xyz { 405 superclass parent 406 } 407 oo::copy [xyz new] 408} -returnCodes error -cleanup { 409 parent destroy 410} -result {may not clone a singleton object} 411 412 413test ooUtil-5.1 {TIP 478: abstract} -setup { 414 oo::class create parent 415} -body { 416 oo::abstract create xyz { 417 superclass parent 418 method foo {} {return 123} 419 } 420 oo::class create pqr { 421 superclass xyz 422 method bar {} {return 456} 423 } 424 set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] 425 set x [pqr new] 426 set y [pqr create ::y] 427 lappend codes [$x foo] [$x bar] $y 428} -cleanup { 429 parent destroy 430} -result {1 1 1 123 456 ::y} 431 432test ooUtil-6.1 {TIP 478: classvarable} -setup { 433 oo::class create parent 434} -body { 435 oo::class create xyz { 436 superclass parent 437 initialise { 438 variable x 1 y 2 439 } 440 method a {} { 441 classvariable x 442 incr x 443 } 444 method b {} { 445 classvariable y 446 incr y 447 } 448 method c {} { 449 classvariable x y 450 list $x $y 451 } 452 } 453 set p [xyz new] 454 set q [xyz new] 455 set result [list [$p c] [$q c]] 456 $p a 457 $q b 458 lappend result [[xyz new] c] 459} -cleanup { 460 parent destroy 461} -result {{1 2} {1 2} {2 3}} 462test ooUtil-6.2 {TIP 478: classvarable error case} -setup { 463 oo::class create parent 464} -body { 465 oo::class create xyz { 466 superclass parent 467 method a {} { 468 classvariable x(1) 469 incr x(1) 470 } 471 } 472 set p [xyz new] 473 set q [xyz new] 474 list [$p a] [$q a] 475} -returnCodes error -cleanup { 476 parent destroy 477} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} 478test ooUtil-6.3 {TIP 478: classvarable error case} -setup { 479 oo::class create parent 480} -body { 481 oo::class create xyz { 482 superclass parent 483 method a {} { 484 classvariable ::x 485 incr x 486 } 487 } 488 set p [xyz new] 489 set q [xyz new] 490 list [$p a] [$q a] 491} -returnCodes error -cleanup { 492 parent destroy 493} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} 494 495test ooUtil-7.1 {TIP 478: link calling pattern} -setup { 496 oo::class create parent 497} -body { 498 oo::class create cls { 499 superclass parent 500 method foo {} {return "in foo of [self]"} 501 method Bar {} {return "in bar of [self]"} 502 method Grill {} {return "in grill of [self]"} 503 export eval 504 constructor {} { 505 link foo 506 link {bar Bar} {grill Grill} 507 } 508 } 509 cls create o 510 o eval {list [foo] [bar] [grill]} 511} -cleanup { 512 parent destroy 513} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} 514test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { 515 oo::class create parent 516} -body { 517 oo::class create cls { 518 superclass parent 519 method foo {} {return "in foo of [self]"} 520 constructor {cmd} { 521 link [list ::$cmd foo] 522 } 523 } 524 cls create o pqr 525 list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg 526} -cleanup { 527 parent destroy 528} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} 529 530# Tests that verify issues detected with the tcllib version of the code 531test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { 532 oo::class create animal {} 533 namespace eval ::ooutiltest { 534 oo::class create pet { superclass animal } 535 } 536} -body { 537 namespace eval ::ooutiltest { 538 oo::class create dog { superclass pet } 539 } 540} -cleanup { 541 namespace delete ooutiltest 542 rename animal {} 543} -result {::ooutiltest::dog} 544test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { 545 oo::class create TestClass { 546 superclass oo::class 547 self method create {name ignore body} { 548 next $name $body 549 } 550 } 551} -body { 552 TestClass create okay {} {} 553} -cleanup { 554 rename TestClass {} 555} -result {::okay} 556 557cleanupTests 558return 559 560# Local Variables: 561# fill-column: 78 562# mode: tcl 563# End: 564