diff options
Diffstat (limited to 'tests/oo.test')
-rw-r--r-- | tests/oo.test | 44 |
1 files changed, 44 insertions, 0 deletions
diff --git a/tests/oo.test b/tests/oo.test index 9491f78..ccb05c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2017,6 +2017,12 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2156,6 +2162,12 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -3412,6 +3424,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Master { + superclass Super + variable member1 member2 + constructor {} { + set member1 master1 + set member2 master2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Master new] getChild] result +} -cleanup { + Super destroy +} -result {master1 master2 master1 master2 master1 master2 master1 master2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... |