Subversion Repositories or1k

#
# Tests for deleting classes and objects
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: delete.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
# ----------------------------------------------------------------------
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[string compare test [info procs test]] == 1} then {source defs}

# ----------------------------------------------------------------------
#  Deleting classes and objects
# ----------------------------------------------------------------------
test delete-1.1 {define a simple classes with inheritance} {
    itcl::class test_delete_base {
        variable num 0
        method show {} {
            return $num
        }
    }
} ""

test delete-1.2 {create some base class objects} {
    for {set i 0} {$i < 5} {incr i} {
        test_delete_base #auto
    }
    lsort [find objects -class test_delete_base]
} {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} {
    list [delete class test_delete_base] \
         [find classes test_delete_base] \
         [namespace children :: test_delete_base] \
         [namespace which -command test_delete_base] \
         [find objects test_delete_base*]
} {{} {} {} {} {}}

# ----------------------------------------------------------------------
#  Deleting classes and objects with inheritance
# ----------------------------------------------------------------------
test delete-2.1 {define a simple classes with inheritance} {
    variable ::test_delete_watch ""
    itcl::class test_delete_base {
        variable num 0
        method show {} {
            return $num
        }
        destructor {
            global ::test_delete_watch
            lappend test_delete_watch $this
        }
    }
    itcl::class test_delete {
        inherit test_delete_base
        method show {} {
            return ">$num<"
        }
    }
} ""

test delete-2.2 {create some base and derived class objects} {
    for {set i 0} {$i < 3} {incr i} {
        test_delete_base #auto
    }
    for {set i 0} {$i < 3} {incr i} {
        test_delete #auto
    }
    lsort [find objects -isa test_delete_base]
} {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} {
    list [delete class test_delete_base] \
         [find classes test_delete*] \
         [namespace children :: test_delete*] \
         [namespace which -command test_delete_base] \
         [namespace which -command test_delete] \
         [find objects test_delete*]
} {{} {} {} {} {} {}}

test delete-2.4 {object destructors get invoked properly} {
    lsort $test_delete_watch
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}

# ----------------------------------------------------------------------
#  Deleting class namespaces
# ----------------------------------------------------------------------
test delete-3.1 {redefine classes with inheritance} {
    variable ::test_delete_watch ""
    itcl::class test_delete_base {
        variable num 0
        method show {} {
            return $num
        }
        destructor {
            global test_delete_watch
            lappend test_delete_watch $this
        }
    }
    itcl::class test_delete {
        inherit test_delete_base
        method show {} {
            return ">$num<"
        }
    }
} ""

test delete-3.2 {create some base and derived class objects} {
    for {set i 0} {$i < 3} {incr i} {
        test_delete_base #auto
    }
    for {set i 0} {$i < 3} {incr i} {
        test_delete #auto
    }
    lsort [find objects -isa test_delete_base]
} {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} {
    list [namespace delete test_delete_base] \
         [find classes test_delete*] \
         [namespace children :: test_delete*] \
         [namespace which -command test_delete_base] \
         [namespace which -command test_delete] \
         [find objects test_delete*]
} {{} {} {} {} {} {}}

test delete-3.4 {object destructors get invoked, even during catastrophe} {
    lsort $test_delete_watch
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}

# ----------------------------------------------------------------------
#  Self-destructing objects
# ----------------------------------------------------------------------
test basic-4.1 {define a class where objects destroy themselves} {
    itcl::class test_delete {
        public variable x ""
        public variable deletecommand ""
        constructor {args} {
            eval configure $args
        }
        destructor {
            eval $deletecommand
        }
        method killme {code} {
            delete object $this
            eval $code
        }
    }
} {}

test basic-4.2 {an object can delete itself} {
    set obj [test_delete #auto -x "data stays"]
    list [$obj killme {return $x}] [find objects -isa test_delete]
} {{data stays} {}}

test basic-4.3 {the "this" variable becomes null after delete} {
    set obj [test_delete #auto]
    list [$obj killme {return $this}] [find objects -isa test_delete]
} {{} {}}

test basic-4.4 {an object being destructed can't be deleted} {
    set obj [test_delete #auto -deletecommand {delete object $this}]
    list [catch {delete object $obj} msg] $msg
} {1 {can't delete an object while it is being destructed}}

namespace delete test_delete

# ----------------------------------------------------------------------
#  Delete objects using path names and scoped values
# ----------------------------------------------------------------------
test basic-5.1 {define a simple class} {
    itcl::class test_delete_name {
        private variable x 0
        method test {x} {
            return $x
        }
    }
} {}

test basic-5.2 {delete using a qualified name} {
    namespace eval test_delete2 {test_delete_name #auto}
    set cmd {delete object test_delete2::test_delete_name0}
    list [catch $cmd msg] $msg [find objects -isa test_delete_name]
} {0 {} {}}

test basic-5.3 {delete using a scoped value} {
    set obj [namespace eval test_delete2 {code [test_delete_name #auto]}]
    set cmd [list delete object $obj]
    list [catch $cmd msg] $msg [find objects -isa test_delete_name]
} {0 {} {}}

test basic-5.4 {scoped command names are decoded properly} {
    list [catch {delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
         [catch {delete object {namespace inscope :: xxx yyy}} 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}}

namespace delete test_delete_name test_delete2