1# 2# Tests for deleting classes and objects 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# Copyright (c) 1993-1998 Lucent Technologies, Inc. 10# ====================================================================== 11# See the file "license.terms" for information on usage and 12# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14package require tcltest 2.2 15namespace import ::tcltest::test 16::tcltest::loadTestedCommands 17package require itcl 18 19# ---------------------------------------------------------------------- 20# Deleting classes and objects 21# ---------------------------------------------------------------------- 22test delete-1.1 {define a simple classes with inheritance} { 23 itcl::class test_delete_base { 24 variable num 0 25 method show {} { 26 return $num 27 } 28 } 29} "" 30 31test delete-1.2 {create some base class objects} { 32 for {set i 0} {$i < 5} {incr i} { 33 test_delete_base #auto 34 } 35 lsort [itcl::find objects -class test_delete_base] 36} {test_delete_base0 test_delete_base1 test_delete_base2 test_delete_base3 test_delete_base4} 37 38test delete-1.3 {delete the base class--class and all objects go away} { 39 list [itcl::delete class test_delete_base] \ 40 [itcl::find classes test_delete_base] \ 41 [namespace children :: test_delete_base] \ 42 [namespace which -command test_delete_base] \ 43 [itcl::find objects test_delete_base*] 44} {{} {} {} {} {}} 45 46# ---------------------------------------------------------------------- 47# Deleting classes and objects with inheritance 48# ---------------------------------------------------------------------- 49test delete-2.1 {define a simple classes with inheritance} { 50 variable ::test_delete_watch "" 51 itcl::class test_delete_base { 52 variable num 0 53 method show {} { 54 return $num 55 } 56 destructor { 57 global ::test_delete_watch 58 lappend test_delete_watch $this 59 } 60 } 61 itcl::class test_delete { 62 inherit test_delete_base 63 method show {} { 64 return ">$num<" 65 } 66 } 67} "" 68 69test delete-2.2 {create some base and derived class objects} { 70 for {set i 0} {$i < 3} {incr i} { 71 test_delete_base #auto 72 } 73 for {set i 0} {$i < 3} {incr i} { 74 test_delete #auto 75 } 76 lsort [itcl::find objects -isa test_delete_base] 77} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2} 78 79test delete-2.3 {delete the base class--class and all objects go away} { 80 list [itcl::delete class test_delete_base] \ 81 [itcl::find classes test_delete*] \ 82 [namespace children :: test_delete*] \ 83 [namespace which -command test_delete_base] \ 84 [namespace which -command test_delete] \ 85 [itcl::find objects test_delete*] 86} {{} {} {} {} {} {}} 87 88test delete-2.4 {object destructors get invoked properly} { 89 lsort $test_delete_watch 90} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2} 91 92# ---------------------------------------------------------------------- 93# Deleting class namespaces 94# ---------------------------------------------------------------------- 95test delete-3.1 {redefine classes with inheritance} { 96 variable ::test_delete_watch "" 97 itcl::class test_delete_base { 98 variable num 0 99 method show {} { 100 return $num 101 } 102 destructor { 103 global test_delete_watch 104 lappend test_delete_watch $this 105 } 106 } 107 itcl::class test_delete { 108 inherit test_delete_base 109 method show {} { 110 return ">$num<" 111 } 112 } 113} "" 114 115test delete-3.2 {create some base and derived class objects} { 116 for {set i 0} {$i < 3} {incr i} { 117 test_delete_base #auto 118 } 119 for {set i 0} {$i < 3} {incr i} { 120 test_delete #auto 121 } 122 lsort [itcl::find objects -isa test_delete_base] 123} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2} 124 125test delete-3.3 {deleting a class namespace is like deleting a class} { 126 list [namespace delete test_delete_base] \ 127 [itcl::find classes test_delete*] \ 128 [namespace children :: test_delete*] \ 129 [namespace which -command test_delete_base] \ 130 [namespace which -command test_delete] \ 131 [itcl::find objects test_delete*] 132} {{} {} {} {} {} {}} 133 134test delete-3.4 {object destructors get invoked, even during catastrophe} { 135 lsort $test_delete_watch 136} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2} 137 138 139# ---------------------------------------------------------------------- 140# Self-destructing objects 141# ---------------------------------------------------------------------- 142test delete-4.1 {define a class where objects destroy themselves} { 143 itcl::class test_delete { 144 public variable x "" 145 public variable deletecommand "" 146 constructor {args} { 147 eval configure $args 148 } 149 destructor { 150 eval $deletecommand 151 } 152 method killme {code} { 153 itcl::delete object $this 154 eval $code 155 } 156 } 157} {} 158 159test delete-4.2 {an object can delete itself 160} -body { 161 set obj [test_delete #auto -x "data stays"] 162 list [$obj killme {return $x}] [itcl::find objects -isa test_delete] 163} -constraints { 164 only_working_in_itcl3.4 165} -result {{data stays} {}} 166 167test delete-4.3 {the "this" variable becomes null after delete} { 168 set obj [test_delete #auto] 169 list [$obj killme {return $this}] [itcl::find objects -isa test_delete] 170} {{} {}} 171 172test delete-4.4 {an object being destructed can't be deleted} { 173 set obj [test_delete #auto -deletecommand {itcl::delete object $this}] 174 list [catch {itcl::delete object $obj} msg] $msg 175} {1 {can't delete an object while it is being destructed}} 176 177if {[namespace which [namespace current]::test_delete] ne {}} { 178 namespace delete test_delete 179} 180 181# ---------------------------------------------------------------------- 182# Delete objects using path names and scoped values 183# ---------------------------------------------------------------------- 184test delete-5.1 {define a simple class} { 185 itcl::class test_delete_name { 186 private variable x 0 187 method test {x} { 188 return $x 189 } 190 } 191} {} 192 193test delete-5.2 {delete using a qualified name} { 194 namespace eval test_delete2 {test_delete_name #auto} 195 set cmd {itcl::delete object test_delete2::test_delete_name0} 196 list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name] 197} {0 {} {}} 198 199test delete-5.3 {delete using a scoped value} { 200 set obj [namespace eval test_delete2 {itcl::code [test_delete_name #auto]}] 201 set cmd [list itcl::delete object $obj] 202 list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name] 203} {0 {} {}} 204 205test delete-5.4 {scoped command names are decoded properly} { 206 list [catch {itcl::delete object {namespace inscope ::xyzzy xxx}} msg] $msg \ 207 [catch {itcl::delete object {namespace inscope :: xxx yyy}} msg] $msg \ 208 [catch {itcl::delete object {namespace inscope :: xyzzy}} msg] $msg 209} {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}} 210 211namespace delete test_delete_name test_delete2 212 213::tcltest::cleanupTests 214return 215