#
|
#
|
# Tests for deleting classes and objects
|
# Tests for deleting classes and objects
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# AUTHOR: Michael J. McLennan
|
# AUTHOR: Michael J. McLennan
|
# Bell Labs Innovations for Lucent Technologies
|
# Bell Labs Innovations for Lucent Technologies
|
# mmclennan@lucent.com
|
# mmclennan@lucent.com
|
# http://www.tcltk.com/itcl
|
# http://www.tcltk.com/itcl
|
#
|
#
|
# RCS: $Id: delete.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# RCS: $Id: delete.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# ======================================================================
|
# ======================================================================
|
# See the file "license.terms" for information on usage and
|
# See the file "license.terms" for information on usage and
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Deleting classes and objects
|
# Deleting classes and objects
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test delete-1.1 {define a simple classes with inheritance} {
|
test delete-1.1 {define a simple classes with inheritance} {
|
itcl::class test_delete_base {
|
itcl::class test_delete_base {
|
variable num 0
|
variable num 0
|
method show {} {
|
method show {} {
|
return $num
|
return $num
|
}
|
}
|
}
|
}
|
} ""
|
} ""
|
|
|
test delete-1.2 {create some base class objects} {
|
test delete-1.2 {create some base class objects} {
|
for {set i 0} {$i < 5} {incr i} {
|
for {set i 0} {$i < 5} {incr i} {
|
test_delete_base #auto
|
test_delete_base #auto
|
}
|
}
|
lsort [find objects -class test_delete_base]
|
lsort [find objects -class test_delete_base]
|
} {test_delete_base0 test_delete_base1 test_delete_base2 test_delete_base3 test_delete_base4}
|
} {test_delete_base0 test_delete_base1 test_delete_base2 test_delete_base3 test_delete_base4}
|
|
|
test delete-1.3 {delete the base class--class and all objects go away} {
|
test delete-1.3 {delete the base class--class and all objects go away} {
|
list [delete class test_delete_base] \
|
list [delete class test_delete_base] \
|
[find classes test_delete_base] \
|
[find classes test_delete_base] \
|
[namespace children :: test_delete_base] \
|
[namespace children :: test_delete_base] \
|
[namespace which -command test_delete_base] \
|
[namespace which -command test_delete_base] \
|
[find objects test_delete_base*]
|
[find objects test_delete_base*]
|
} {{} {} {} {} {}}
|
} {{} {} {} {} {}}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Deleting classes and objects with inheritance
|
# Deleting classes and objects with inheritance
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test delete-2.1 {define a simple classes with inheritance} {
|
test delete-2.1 {define a simple classes with inheritance} {
|
variable ::test_delete_watch ""
|
variable ::test_delete_watch ""
|
itcl::class test_delete_base {
|
itcl::class test_delete_base {
|
variable num 0
|
variable num 0
|
method show {} {
|
method show {} {
|
return $num
|
return $num
|
}
|
}
|
destructor {
|
destructor {
|
global ::test_delete_watch
|
global ::test_delete_watch
|
lappend test_delete_watch $this
|
lappend test_delete_watch $this
|
}
|
}
|
}
|
}
|
itcl::class test_delete {
|
itcl::class test_delete {
|
inherit test_delete_base
|
inherit test_delete_base
|
method show {} {
|
method show {} {
|
return ">$num<"
|
return ">$num<"
|
}
|
}
|
}
|
}
|
} ""
|
} ""
|
|
|
test delete-2.2 {create some base and derived class objects} {
|
test delete-2.2 {create some base and derived class objects} {
|
for {set i 0} {$i < 3} {incr i} {
|
for {set i 0} {$i < 3} {incr i} {
|
test_delete_base #auto
|
test_delete_base #auto
|
}
|
}
|
for {set i 0} {$i < 3} {incr i} {
|
for {set i 0} {$i < 3} {incr i} {
|
test_delete #auto
|
test_delete #auto
|
}
|
}
|
lsort [find objects -isa test_delete_base]
|
lsort [find objects -isa test_delete_base]
|
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
|
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
|
|
|
test delete-2.3 {delete the base class--class and all objects go away} {
|
test delete-2.3 {delete the base class--class and all objects go away} {
|
list [delete class test_delete_base] \
|
list [delete class test_delete_base] \
|
[find classes test_delete*] \
|
[find classes test_delete*] \
|
[namespace children :: test_delete*] \
|
[namespace children :: test_delete*] \
|
[namespace which -command test_delete_base] \
|
[namespace which -command test_delete_base] \
|
[namespace which -command test_delete] \
|
[namespace which -command test_delete] \
|
[find objects test_delete*]
|
[find objects test_delete*]
|
} {{} {} {} {} {} {}}
|
} {{} {} {} {} {} {}}
|
|
|
test delete-2.4 {object destructors get invoked properly} {
|
test delete-2.4 {object destructors get invoked properly} {
|
lsort $test_delete_watch
|
lsort $test_delete_watch
|
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
|
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Deleting class namespaces
|
# Deleting class namespaces
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test delete-3.1 {redefine classes with inheritance} {
|
test delete-3.1 {redefine classes with inheritance} {
|
variable ::test_delete_watch ""
|
variable ::test_delete_watch ""
|
itcl::class test_delete_base {
|
itcl::class test_delete_base {
|
variable num 0
|
variable num 0
|
method show {} {
|
method show {} {
|
return $num
|
return $num
|
}
|
}
|
destructor {
|
destructor {
|
global test_delete_watch
|
global test_delete_watch
|
lappend test_delete_watch $this
|
lappend test_delete_watch $this
|
}
|
}
|
}
|
}
|
itcl::class test_delete {
|
itcl::class test_delete {
|
inherit test_delete_base
|
inherit test_delete_base
|
method show {} {
|
method show {} {
|
return ">$num<"
|
return ">$num<"
|
}
|
}
|
}
|
}
|
} ""
|
} ""
|
|
|
test delete-3.2 {create some base and derived class objects} {
|
test delete-3.2 {create some base and derived class objects} {
|
for {set i 0} {$i < 3} {incr i} {
|
for {set i 0} {$i < 3} {incr i} {
|
test_delete_base #auto
|
test_delete_base #auto
|
}
|
}
|
for {set i 0} {$i < 3} {incr i} {
|
for {set i 0} {$i < 3} {incr i} {
|
test_delete #auto
|
test_delete #auto
|
}
|
}
|
lsort [find objects -isa test_delete_base]
|
lsort [find objects -isa test_delete_base]
|
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
|
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
|
|
|
test delete-3.3 {deleting a class namespace is like deleting a class} {
|
test delete-3.3 {deleting a class namespace is like deleting a class} {
|
list [namespace delete test_delete_base] \
|
list [namespace delete test_delete_base] \
|
[find classes test_delete*] \
|
[find classes test_delete*] \
|
[namespace children :: test_delete*] \
|
[namespace children :: test_delete*] \
|
[namespace which -command test_delete_base] \
|
[namespace which -command test_delete_base] \
|
[namespace which -command test_delete] \
|
[namespace which -command test_delete] \
|
[find objects test_delete*]
|
[find objects test_delete*]
|
} {{} {} {} {} {} {}}
|
} {{} {} {} {} {} {}}
|
|
|
test delete-3.4 {object destructors get invoked, even during catastrophe} {
|
test delete-3.4 {object destructors get invoked, even during catastrophe} {
|
lsort $test_delete_watch
|
lsort $test_delete_watch
|
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
|
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Self-destructing objects
|
# Self-destructing objects
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test basic-4.1 {define a class where objects destroy themselves} {
|
test basic-4.1 {define a class where objects destroy themselves} {
|
itcl::class test_delete {
|
itcl::class test_delete {
|
public variable x ""
|
public variable x ""
|
public variable deletecommand ""
|
public variable deletecommand ""
|
constructor {args} {
|
constructor {args} {
|
eval configure $args
|
eval configure $args
|
}
|
}
|
destructor {
|
destructor {
|
eval $deletecommand
|
eval $deletecommand
|
}
|
}
|
method killme {code} {
|
method killme {code} {
|
delete object $this
|
delete object $this
|
eval $code
|
eval $code
|
}
|
}
|
}
|
}
|
} {}
|
} {}
|
|
|
test basic-4.2 {an object can delete itself} {
|
test basic-4.2 {an object can delete itself} {
|
set obj [test_delete #auto -x "data stays"]
|
set obj [test_delete #auto -x "data stays"]
|
list [$obj killme {return $x}] [find objects -isa test_delete]
|
list [$obj killme {return $x}] [find objects -isa test_delete]
|
} {{data stays} {}}
|
} {{data stays} {}}
|
|
|
test basic-4.3 {the "this" variable becomes null after delete} {
|
test basic-4.3 {the "this" variable becomes null after delete} {
|
set obj [test_delete #auto]
|
set obj [test_delete #auto]
|
list [$obj killme {return $this}] [find objects -isa test_delete]
|
list [$obj killme {return $this}] [find objects -isa test_delete]
|
} {{} {}}
|
} {{} {}}
|
|
|
test basic-4.4 {an object being destructed can't be deleted} {
|
test basic-4.4 {an object being destructed can't be deleted} {
|
set obj [test_delete #auto -deletecommand {delete object $this}]
|
set obj [test_delete #auto -deletecommand {delete object $this}]
|
list [catch {delete object $obj} msg] $msg
|
list [catch {delete object $obj} msg] $msg
|
} {1 {can't delete an object while it is being destructed}}
|
} {1 {can't delete an object while it is being destructed}}
|
|
|
namespace delete test_delete
|
namespace delete test_delete
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Delete objects using path names and scoped values
|
# Delete objects using path names and scoped values
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test basic-5.1 {define a simple class} {
|
test basic-5.1 {define a simple class} {
|
itcl::class test_delete_name {
|
itcl::class test_delete_name {
|
private variable x 0
|
private variable x 0
|
method test {x} {
|
method test {x} {
|
return $x
|
return $x
|
}
|
}
|
}
|
}
|
} {}
|
} {}
|
|
|
test basic-5.2 {delete using a qualified name} {
|
test basic-5.2 {delete using a qualified name} {
|
namespace eval test_delete2 {test_delete_name #auto}
|
namespace eval test_delete2 {test_delete_name #auto}
|
set cmd {delete object test_delete2::test_delete_name0}
|
set cmd {delete object test_delete2::test_delete_name0}
|
list [catch $cmd msg] $msg [find objects -isa test_delete_name]
|
list [catch $cmd msg] $msg [find objects -isa test_delete_name]
|
} {0 {} {}}
|
} {0 {} {}}
|
|
|
test basic-5.3 {delete using a scoped value} {
|
test basic-5.3 {delete using a scoped value} {
|
set obj [namespace eval test_delete2 {code [test_delete_name #auto]}]
|
set obj [namespace eval test_delete2 {code [test_delete_name #auto]}]
|
set cmd [list delete object $obj]
|
set cmd [list delete object $obj]
|
list [catch $cmd msg] $msg [find objects -isa test_delete_name]
|
list [catch $cmd msg] $msg [find objects -isa test_delete_name]
|
} {0 {} {}}
|
} {0 {} {}}
|
|
|
test basic-5.4 {scoped command names are decoded properly} {
|
test basic-5.4 {scoped command names are decoded properly} {
|
list [catch {delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
|
list [catch {delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
|
[catch {delete object {namespace inscope :: xxx yyy}} msg] $msg \
|
[catch {delete object {namespace inscope :: xxx yyy}} msg] $msg \
|
[catch {delete object {namespace inscope :: xyzzy}} msg] $msg
|
[catch {delete object {namespace inscope :: xyzzy}} msg] $msg
|
} {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}}
|
} {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}}
|
|
|
namespace delete test_delete_name test_delete2
|
namespace delete test_delete_name test_delete2
|
|
|