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