OpenCores

/interp.test

0,0 → 1,68

interp.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: inherit.test =================================================================== --- inherit.test (nonexistent) +++ inherit.test (revision 1765) @@ -0,0 +1,576 @@ +# +# Tests for inheritance and scope handling +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: inherit.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} + +# ---------------------------------------------------------------------- +# Test construction/destruction with inheritance +# ---------------------------------------------------------------------- +test inherit-1.1 {define classes with constructors/destructors} { + variable ::test_cd_watch "" + itcl::class test_cd_foo { + constructor {x y} { + global ::test_cd_watch + lappend test_cd_watch "foo: $x $y" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "foo destruct" + } + } + itcl::class test_cd_bar { + constructor {args} { + global ::test_cd_watch + lappend test_cd_watch "bar: $args" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "bar destruct" + } + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + constructor {x y args} { + test_cd_foo::constructor $x $y + } { + global ::test_cd_watch + lappend test_cd_watch "foobar: $x $y ($args)" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "foobar destruct" + } + } + itcl::class test_cd_geek { + constructor {} { + global ::test_cd_watch + lappend test_cd_watch "geek" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "geek destruct" + } + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + constructor {x} { + eval test_cd_foobar::constructor 1 2 fred $x + } { + global ::test_cd_watch + lappend test_cd_watch "mongrel: $x" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "mongrel destruct" + } + } + itcl::class test_cd_none { + inherit test_cd_bar test_cd_geek + } + itcl::class test_cd_skip { + inherit test_cd_none + constructor {} { + global ::test_cd_watch + lappend test_cd_watch "skip" + } + destructor { + global ::test_cd_watch + lappend test_cd_watch "skip destruct" + } + } +} {} + +test inherit-1.2 {constructors should be invoked in the proper order} { + set ::test_cd_watch "" + list [test_cd_mongrel #auto bob] [set ::test_cd_watch] +} {test_cd_mongrel0 {{foo: 1 2} {bar: } {foobar: 1 2 (fred bob)} geek {mongrel: bob}}} + +test inherit-1.3 {destructors should be invoked in the proper order} { + set ::test_cd_watch "" + list [delete object test_cd_mongrel0] [set ::test_cd_watch] +} {{} {{mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} + +test inherit-1.4 {constructors are optional} { + set ::test_cd_watch "" + list [test_cd_none #auto] [set ::test_cd_watch] +} {test_cd_none0 {geek {bar: }}} + +test inherit-1.5 {destructors are optional} { + set ::test_cd_watch "" + list [delete object test_cd_none0] [set ::test_cd_watch] +} {{} {{bar destruct} {geek destruct}}} + +test inherit-1.6 {construction ok if constructors are missing} { + set ::test_cd_watch "" + list [test_cd_skip #auto] [set ::test_cd_watch] +} {test_cd_skip0 {geek {bar: } skip}} + +test inherit-1.7 {destruction ok if destructors are missing} { + set ::test_cd_watch "" + list [delete object test_cd_skip0] [set ::test_cd_watch] +} {{} {{skip destruct} {bar destruct} {geek destruct}}} + +test inherit-1.8 {errors during construction are cleaned up and reported} { + global errorInfo test_cd_watch + set test_cd_watch "" + body test_cd_bar::constructor {args} {error "bar: failed"} + list [catch {test_cd_mongrel #auto bob} msg] $msg \ + $errorInfo $test_cd_watch +} {1 {bar: failed} {bar: failed + while executing +"error "bar: failed"" + while constructing object "::test_cd_mongrel1" in ::test_cd_bar::constructor (body line 1) + while constructing object "::test_cd_mongrel1" in ::test_cd_foobar::constructor (body line 1) + invoked from within +"test_cd_foobar::constructor 1 2 fred bob" + ("eval" body line 1) + invoked from within +"eval test_cd_foobar::constructor 1 2 fred $x" + while constructing object "::test_cd_mongrel1" in ::test_cd_mongrel::constructor (body line 2) + invoked from within +"test_cd_mongrel #auto bob"} {{foo: 1 2} {mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} + +test inherit-1.9 {errors during destruction prevent object delete} { + global errorInfo test_cd_watch + body test_cd_bar::constructor {args} {return "bar: $args"} + body test_cd_bar::destructor {} {error "bar: failed"} + test_cd_mongrel mongrel1 ted + set test_cd_watch "" + list [catch {delete object mongrel1} msg] $msg \ + $errorInfo $test_cd_watch [find objects mongrel*] +} {1 {bar: failed} {bar: failed + while executing +"error "bar: failed"" + while deleting object "::mongrel1" in ::test_cd_bar::destructor (body line 1) + invoked from within +"delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} + +test inherit-1.10 {errors during destruction prevent class delete} { + list [catch {delete class test_cd_foo} msg] $msg +} {1 {bar: failed}} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test data member access and scoping +# ---------------------------------------------------------------------- +test inherit-2.1 {define classes with data members} { + itcl::class test_cd_foo { + protected variable x "foo-x" + method do {args} {eval $args} + } + itcl::class test_cd_bar { + protected variable x "bar-x" + method do {args} {eval $args} + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + method do {args} {eval $args} + } + itcl::class test_cd_geek { + method do {args} {eval $args} + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + protected variable x "mongrel-x" + method do {args} {eval $args} + } +} {} + +test inherit-2.2 {"info" provides access to shadowed data members} { + test_cd_mongrel #auto + list [lsort [test_cd_mongrel0 info variable]] \ + [test_cd_mongrel0 info variable test_cd_foo::x] \ + [test_cd_mongrel0 info variable test_cd_bar::x] \ + [test_cd_mongrel0 info variable test_cd_mongrel::x] \ + [test_cd_mongrel0 info variable x] +} {{::test_cd_bar::x ::test_cd_foo::x ::test_cd_mongrel::this ::test_cd_mongrel::x} {protected variable ::test_cd_foo::x foo-x foo-x} {protected variable ::test_cd_bar::x bar-x bar-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x}} + +test inherit-2.3 {variable resolution works properly in methods} { + list [test_cd_mongrel0 test_cd_foo::do set x] \ + [test_cd_mongrel0 test_cd_bar::do set x] \ + [test_cd_mongrel0 test_cd_foobar::do set x] \ + [test_cd_mongrel0 test_cd_mongrel::do set x] +} {foo-x bar-x foo-x mongrel-x} + +test inherit-2.4 {methods have access to shadowed data members} { + list [test_cd_mongrel0 test_cd_foobar::do set x] \ + [test_cd_mongrel0 test_cd_foobar::do set test_cd_foo::x] \ + [test_cd_mongrel0 test_cd_foobar::do set test_cd_bar::x] \ + [test_cd_mongrel0 test_cd_mongrel::do set test_cd_foo::x] \ + [test_cd_mongrel0 test_cd_mongrel::do set test_cd_bar::x] +} {foo-x foo-x bar-x foo-x bar-x} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test public variables and "configure" method +# ---------------------------------------------------------------------- +test inherit-3.1 {define classes with public variables} { + variable ::test_cd_watch "" + itcl::class test_cd_foo { + public variable x "foo-x" { + global test_cd_watch + lappend test_cd_watch "foo: $x in scope [namespace current]" + } + method do {args} {eval $args} + } + itcl::class test_cd_bar { + public variable x "bar-x" { + global test_cd_watch + lappend test_cd_watch "bar: $x in scope [namespace current]" + } + method do {args} {eval $args} + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + method do {args} {eval $args} + } + itcl::class test_cd_geek { + method do {args} {eval $args} + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + public variable x "mongrel-x" { + global test_cd_watch + lappend test_cd_watch "mongrel: $x in scope [namespace current]" + } + method do {args} {eval $args} + } +} {} + +test inherit-3.2 {create an object with public variables} { + test_cd_mongrel #auto +} {test_cd_mongrel0} + +test inherit-3.3 {"configure" lists all public variables} { + lsort [test_cd_mongrel0 configure] +} {{-test_cd_bar::x bar-x bar-x} {-test_cd_foo::x foo-x foo-x} {-x mongrel-x mongrel-x}} + +test inherit-3.4 {"configure" treats simple names as "most specific"} { + lsort [test_cd_mongrel0 configure -x] +} {-x mongrel-x mongrel-x} + +test inherit-3.5 {"configure" treats simple names as "most specific"} { + set ::test_cd_watch "" + list [test_cd_mongrel0 configure -x hello] \ + [set ::test_cd_watch] +} {{} {{mongrel: hello in scope ::test_cd_mongrel}}} + +test inherit-3.6 {"configure" allows access to shadowed options} { + set ::test_cd_watch "" + list [test_cd_mongrel0 configure -test_cd_foo::x hello] \ + [test_cd_mongrel0 configure -test_cd_bar::x there] \ + [set ::test_cd_watch] +} {{} {} {{foo: hello in scope ::test_cd_foo} {bar: there in scope ::test_cd_bar}}} + +test inherit-3.7 {"configure" will change several variables at once} { + set ::test_cd_watch "" + list [test_cd_mongrel0 configure -x one \ + -test_cd_foo::x two \ + -test_cd_bar::x three] \ + [set ::test_cd_watch] +} {{} {{mongrel: one in scope ::test_cd_mongrel} {foo: two in scope ::test_cd_foo} {bar: three in scope ::test_cd_bar}}} + +test inherit-3.8 {"cget" does proper name resolution} { + list [test_cd_mongrel0 cget -x] \ + [test_cd_mongrel0 cget -test_cd_foo::x] \ + [test_cd_mongrel0 cget -test_cd_bar::x] \ + [test_cd_mongrel0 cget -test_cd_mongrel::x] +} {one two three one} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test inheritance info +# ---------------------------------------------------------------------- +test inherit-4.1 {define classes for inheritance info} { + itcl::class test_cd_foo { + method do {args} {eval $args} + } + itcl::class test_cd_bar { + method do {args} {eval $args} + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + method do {args} {eval $args} + } + itcl::class test_cd_geek { + method do {args} {eval $args} + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + method do {args} {eval $args} + } +} {} + +test inherit-4.2 {create an object for inheritance tests} { + test_cd_mongrel #auto +} {test_cd_mongrel0} + +test inherit-4.3 {"info class" should be virtual} { + list [test_cd_mongrel0 info class] \ + [test_cd_mongrel0 test_cd_foo::do info class] \ + [test_cd_mongrel0 test_cd_geek::do info class] +} {::test_cd_mongrel ::test_cd_mongrel ::test_cd_mongrel} + +test inherit-4.4 {"info inherit" depends on class scope} { + list [test_cd_mongrel0 info inherit] \ + [test_cd_mongrel0 test_cd_foo::do info inherit] \ + [test_cd_mongrel0 test_cd_foobar::do info inherit] +} {{::test_cd_foobar ::test_cd_geek} {} {::test_cd_foo ::test_cd_bar}} + +test inherit-4.5 {"info heritage" depends on class scope} { + list [test_cd_mongrel0 info heritage] \ + [test_cd_mongrel0 test_cd_foo::do info heritage] \ + [test_cd_mongrel0 test_cd_foobar::do info heritage] +} {{::test_cd_mongrel ::test_cd_foobar ::test_cd_foo ::test_cd_bar ::test_cd_geek} ::test_cd_foo {::test_cd_foobar ::test_cd_foo ::test_cd_bar}} + +test inherit-4.6 {built-in "isa" method works} { + set status "" + foreach c [test_cd_mongrel0 info heritage] { + lappend status [test_cd_mongrel0 isa $c] + } + set status +} {1 1 1 1 1} + +test inherit-4.7 {built-in "isa" method works within methods} { + set status "" + foreach c [test_cd_mongrel0 info heritage] { + lappend status [test_cd_mongrel0 test_cd_foo::do isa $c] + } + set status +} {1 1 1 1 1} + +test inherit-4.8 {built-in "isa" method recognizes bad classes} { + class test_cd_other {} + test_cd_mongrel0 isa test_cd_other +} {0} + +test inherit-4.9 {built-in "isa" method recognizes bad classes} { + list [catch {test_cd_mongrel0 isa test_cd_bogus} msg] $msg +} {1 {class "test_cd_bogus" not found in context "::test_cd_foo"}} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test "find objects" +# ---------------------------------------------------------------------- +test inherit-5.1 {define classes for inheritance info} { + itcl::class test_cd_foo { + } + itcl::class test_cd_bar { + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + } + itcl::class test_cd_geek { + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + } +} {} + +test inherit-5.2 {create objects for info tests} { + list [test_cd_foo #auto] [test_cd_foo #auto] \ + [test_cd_foobar #auto] \ + [test_cd_geek #auto] \ + [test_cd_mongrel #auto] +} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_geek0 test_cd_mongrel0} + +test inherit-5.3 {find objects: -class qualifier} { + lsort [find objects -class test_cd_foo] +} {test_cd_foo0 test_cd_foo1} + +test inherit-5.4 {find objects: -class qualifier} { + lsort [find objects -class test_cd_mongrel] +} {test_cd_mongrel0} + +test inherit-5.5 {find objects: -isa qualifier} { + lsort [find objects -isa test_cd_foo] +} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_mongrel0} + +test inherit-5.6 {find objects: -isa qualifier} { + lsort [find objects -isa test_cd_mongrel] +} {test_cd_mongrel0} + +test inherit-5.7 {find objects: name qualifier} { + lsort [find objects test_cd_foo*] +} {test_cd_foo0 test_cd_foo1 test_cd_foobar0} + +test inherit-5.8 {find objects: -class and -isa qualifiers} { + lsort [find objects -isa test_cd_foo -class test_cd_foobar] +} {test_cd_foobar0} + +test inherit-5.9 {find objects: -isa and name qualifiers} { + lsort [find objects -isa test_cd_foo *0] +} {test_cd_foo0 test_cd_foobar0 test_cd_mongrel0} + +test inherit-5.10 {find objects: usage errors} { + list [catch {find objects -xyzzy} msg] $msg +} {1 {wrong # args: should be "find objects ?-class className? ?-isa className? ?pattern?"}} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test method scoping and execution +# ---------------------------------------------------------------------- +test inherit-6.1 {define classes for scope tests} { + itcl::class test_cd_foo { + method check {} {return "foo"} + method do {args} {return "foo says: [eval $args]"} + } + itcl::class test_cd_bar { + method check {} {return "bar"} + method do {args} {return "bar says: [eval $args]"} + } + itcl::class test_cd_foobar { + inherit test_cd_foo test_cd_bar + method check {} {return "foobar"} + method do {args} {return "foobar says: [eval $args]"} + } + itcl::class test_cd_geek { + method check {} {return "geek"} + method do {args} {return "geek says: [eval $args]"} + } + itcl::class test_cd_mongrel { + inherit test_cd_foobar test_cd_geek + method check {} {return "mongrel"} + method do {args} {return "mongrel says: [eval $args]"} + } +} {} + +test inherit-6.2 {create objects for scoping tests} { + list [test_cd_mongrel #auto] [test_cd_foobar #auto] +} {test_cd_mongrel0 test_cd_foobar0} + +test inherit-6.3 {methods are "virtual" outside of the class} { + test_cd_mongrel0 check +} {mongrel} + +test inherit-6.4 {specific methods can be accessed by name} { + test_cd_mongrel0 test_cd_foo::check +} {foo} + +test inherit-6.5 {methods are "virtual" within a class too} { + test_cd_mongrel0 test_cd_foobar::do check +} {foobar says: mongrel} + +test inherit-6.6 {methods are executed where they were defined} { + list [test_cd_mongrel0 test_cd_foo::do namespace current] \ + [test_cd_mongrel0 test_cd_foobar::do namespace current] \ + [test_cd_mongrel0 do namespace current] \ +} {{foo says: ::test_cd_foo} {foobar says: ::test_cd_foobar} {mongrel says: ::test_cd_mongrel}} + +test inherit-6.7 {"virtual" command no longer exists} { + list [catch { + test_cd_mongrel0 test_cd_foobar::do virtual namespace current + } msg] $msg +} {1 {invalid command name "virtual"}} + +test inherit-6.8 {"previous" command no longer exists} { + list [catch { + test_cd_mongrel0 test_cd_foobar::do previous check + } msg] $msg +} {1 {invalid command name "previous"}} + +test inherit-6.9 {errors are detected and reported across class boundaries} { + list [catch { + test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error" + } msg] $msg [set ::errorInfo] +} {1 test {some error + ("eval" body line 1) + invoked from within +"eval $args" + (object "::test_cd_foobar0" method "::test_cd_foobar::do" body line 1) + invoked from within +"test_cd_foobar0 do error test {some error}" + ("eval" body line 1) + invoked from within +"eval $args" + (object "::test_cd_mongrel0" method "::test_cd_mongrel::do" body line 1) + invoked from within +"test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error""}} + +test inherit-6.10 {errors codes are preserved across class boundaries} { + list [catch { + test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" CODE-BLUE + } msg] $msg [set ::errorCode] +} {1 test CODE-BLUE} + +test inherit-6.11 {multi-value error codes are preserved across class boundaries} { + list [catch { + test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" "CODE BLUE 123" + } msg] $msg [set ::errorCode] +} {1 test {CODE BLUE 123}} + +eval namespace delete [find classes test_cd_*] + +# ---------------------------------------------------------------------- +# Test inheritance errors +# ---------------------------------------------------------------------- +test inherit-7.1 {cannot inherit from non-existant class} { + list [catch { + itcl::class bogus { + inherit non_existant_class_xyzzy + } + } msg] $msg +} {1 {cannot inherit from "non_existant_class_xyzzy" (class "non_existant_class_xyzzy" not found in context "::")}} + +test inherit-7.2 {cannot inherit from procs} { + proc inherit_test_proc {x y} { + error "never call this" + } + list [catch { + itcl::class bogus { + inherit inherit_test_proc + } + } msg] $msg +} {1 {cannot inherit from "inherit_test_proc" (class "inherit_test_proc" not found in context "::")}} + +test inherit-7.3 {cannot inherit from yourself} { + list [catch { + itcl::class bogus { + inherit bogus + } + } msg] $msg +} {1 {class "bogus" cannot inherit from itself}} + +test inherit-7.4 {cannot have more than one inherit statement} { + list [catch { + itcl::class test_inherit_base1 { } + itcl::class test_inherit_base2 { } + itcl::class bogus { + inherit test_inherit_base1 + inherit test_inherit_base2 + } + } msg] $msg +} {1 {inheritance "test_inherit_base1 " already defined for class "::bogus"}} + +# ---------------------------------------------------------------------- +# Multiple base class error detection +# ---------------------------------------------------------------------- +test inherit-8.1 {cannot inherit from the same base class more than once} { + class test_mi_base {} + class test_mi_foo {inherit test_mi_base} + class test_mi_bar {inherit test_mi_base} + list [catch { + class test_mi_foobar {inherit test_mi_foo test_mi_bar} + } msg] $msg +} {1 {class "::test_mi_foobar" inherits base class "::test_mi_base" more than once: + test_mi_foobar->test_mi_foo->test_mi_base + test_mi_foobar->test_mi_bar->test_mi_base}} + +delete class test_mi_base

inherit.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: delete.test =================================================================== --- delete.test (nonexistent) +++ delete.test (revision 1765) @@ -0,0 +1,204 @@ +# +# 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

delete.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: methods.test =================================================================== --- methods.test (nonexistent) +++ methods.test (revision 1765) @@ -0,0 +1,128 @@ +# +# Tests for argument lists and method execution +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: methods.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} + +# ---------------------------------------------------------------------- +# Methods with various argument lists +# ---------------------------------------------------------------------- +test methods-1.1 {define a class with lots of methods and arg lists} { + itcl::class test_args { + method none {} { + return "none" + } + method two {x y} { + return "two: $x $y" + } + method defvals {x {y def1} {z def2}} { + return "defvals: $x $y $z" + } + method varargs {x {y def1} args} { + return "varargs: $x $y ($args)" + } + method nomagic {args x} { + return "nomagic: $args $x" + } + method clash {x bang boom} { + return "clash: $x $bang $boom" + } + proc crash {x bang boom} { + return "crash: $x $bang $boom" + } + variable bang "ok" + common boom "no-problem" + } +} "" + +test methods-1.2 {create an object to execute tests} { + test_args ta +} {ta} + +test methods-1.3 {argument checking: not enough args} { + list [catch {ta two 1} msg] $msg +} {1 {wrong # args: should be "ta two x y"}} + +test methods-1.4a {argument checking: too many args} { + list [catch {ta two 1 2 3} msg] $msg +} {1 {wrong # args: should be "ta two x y"}} + +test methods-1.4b {argument checking: too many args} { + list [catch {ta none 1 2 3} msg] $msg +} {1 {wrong # args: should be "ta none"}} + +test methods-1.5a {argument checking: just right} { + list [catch {ta two 1 2} msg] $msg +} {0 {two: 1 2}} + +test methods-1.5b {argument checking: just right} { + list [catch {ta none} msg] $msg +} {0 none} + +test methods-1.6a {default arguments: not enough args} { + list [catch {ta defvals} msg] $msg +} {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} + +test methods-1.6b {default arguments: missing arguments supplied} { + list [catch {ta defvals 1} msg] $msg +} {0 {defvals: 1 def1 def2}} + +test methods-1.6c {default arguments: missing arguments supplied} { + list [catch {ta defvals 1 2} msg] $msg +} {0 {defvals: 1 2 def2}} + +test methods-1.6d {default arguments: all arguments assigned} { + list [catch {ta defvals 1 2 3} msg] $msg +} {0 {defvals: 1 2 3}} + +test methods-1.6e {default arguments: too many args} { + list [catch {ta defvals 1 2 3 4} msg] $msg +} {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} + +test methods-1.7a {variable arguments: not enough args} { + list [catch {ta varargs} msg] $msg +} {1 {wrong # args: should be "ta varargs x ?y? ?arg arg ...?"}} + +test methods-1.7b {variable arguments: empty} { + list [catch {ta varargs 1 2} msg] $msg +} {0 {varargs: 1 2 ()}} + +test methods-1.7c {variable arguments: one} { + list [catch {ta varargs 1 2 one} msg] $msg +} {0 {varargs: 1 2 (one)}} + +test methods-1.7d {variable arguments: two} { + list [catch {ta varargs 1 2 one two} msg] $msg +} {0 {varargs: 1 2 (one two)}} + +test methods-1.8 {magic "args" argument has no magic unless at end of list} { + list [catch {ta nomagic 1 2 3 4} msg] $msg +} {1 {wrong # args: should be "ta nomagic args x"}} + +test methods-1.9 {formal args don't clobber class members} { + list [catch {ta clash 1 2 3} msg] $msg \ + [ta info variable bang -value] \ + [ta info variable boom -value] +} {0 {clash: 1 2 3} ok no-problem} + +test methods-1.10 {formal args don't clobber class members} { + list [catch {test_args::crash 4 5 6} msg] $msg \ + [ta info variable bang -value] \ + [ta info variable boom -value] +} {0 {crash: 4 5 6} ok no-problem} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +delete class test_args

methods.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: defs =================================================================== --- defs (nonexistent) +++ defs (revision 1765) @@ -0,0 +1,343 @@ +# This file contains support code for the Tcl test suite. It is +# normally sourced by the individual files in the test suite before +# they run their tests. This improved approach to testing was designed +# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. +# +# Copyright (c) 1990-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) defs 1.44 96/10/08 17:26:58 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +# If tests are being run as root, issue a warning message and set a +# variable to prevent some tests from running at all. + +set user {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*$([^)]*)$} [exec id] dummy user} + } + if {$user == ""} {set user root} + if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." + } +} + +# Some of the tests don't work on some system configurations due to +# differences in word length, file system configuration, etc. In order +# to prevent false alarms, these tests are generally only run in the +# master development directory for Tcl. The presence of a file +# "doAllTests" in this directory is used to indicate that the non-portable +# tests should be run. + +set doNonPortableTests [file exists doAllTests] + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# tempNotPc - The inverse of pcOnly. This flag is used to +# temporarily disable a test. +# nonBlockFiles - 1 means this platform supports setting files into +# nonblocking mode. +# asyncPipeClose- 1 means this platform supports async flush and +# async close on a pipe. +# unixExecs - 1 means this machine has commands such as 'cat', +# 'echo' etc available. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 1 +} else { + set testConfig(unixOnly) 0 +} +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(tempNotPc) 1 + set testConfig(macOnly) 1 +} else { + set testConfig(macOnly) 0 +} +if {$tcl_platform(platform) == "windows"} { + set testConfig(pcOnly) 1 +} else { + set testConfig(pcOnly) 0 +} +set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] +set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] +set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] +set testConfig(nonPortable) [file exists doAllTests] + +set f [open defs r] +if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 +} else { + set testConfig(nonBlockFiles) 0 +} +close $f + +# Test for SCO Unix - cannot run async flushing tests because a potential +# problem with select is apparently interfering. (Mark Diekhans). + +if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set testConfig(asyncPipeClose) 0 + } else { + set testConfig(asyncPipeClose) 1 + } +} else { + set testConfig(asyncPipeClose) 1 +} + +# Test to see if execed commands such as cat, echo, rm and so forth are +# present on this machine. + +set testConfig(unixExecs) 1 +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(unixExecs) 0 +} +if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {$testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set testConfig(unixExecs) 0 + } + } + if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + puts stdout "==== $name $description" + puts stdout "==== Contents of test case:" + puts stdout "$script" + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $answer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $answer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $answer + } + } else { + puts stdout "==== Result was:" + puts stdout "$answer" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} then { + set ok 0 + foreach test $TESTS { + if [string match $test $name] then { + set ok 1 + break + } + } + if !$ok then return + } + set i [llength $args] + if {$i == 0} { + # Empty body + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + return + } + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $script \ + $code $result + } + puts stdout "++++ $name PASSED" + } + } else { + print_verbose $name $description $script \ + $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} + +proc normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete $name +} + +proc makeDirectory {name} { + file mkdir $name +} + +proc removeDirectory {name} { + file delete -force $name +} + +proc viewFile {name} { + global tcl_platform testConfig + if {($tcl_platform(platform) == "macintosh") || \ + ($testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# Locate tcltest executable + +set tcltest [list [info nameofexecutable]] +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + +

defs Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: scope.test =================================================================== --- scope.test (nonexistent) +++ scope.test (revision 1765) @@ -0,0 +1,207 @@ +# +# Tests for code/scope commands +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: scope.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} + +# ---------------------------------------------------------------------- +# Syntax of the "scope" command +# ---------------------------------------------------------------------- +test scope-1.1 {scope command takes one argument} { + list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg +} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}} + +test scope-1.2 {argument to scope command must be a variable} { + variable test_scope_var 0 + list [catch {itcl::scope xyzzy} msg] $msg \ + [catch {itcl::scope test_scope_var} msg] $msg +} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var} + +test scope-1.3 {if variable is already fully qualified, scope does nothing} { + list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var] +} {::xyzzy ::test_scope_var} + +test scope-1.4 {scope command returns fully qualified name} { + namespace eval test_scope_ns { + namespace eval child { + variable v1 0 + itcl::scope v1 + } + } +} {::test_scope_ns::child::v1} + +namespace delete test_scope_ns +unset test_scope_var + +# ---------------------------------------------------------------------- +# Syntax of the "code" command +# ---------------------------------------------------------------------- +test scope-2.1 {code command takes at least one argument} { + list [catch {itcl::code} msg] $msg +} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}} + +test scope-2.2 {code command with one argument} { + itcl::code arg1 +} {namespace inscope :: arg1} + +test scope-2.3 {code command with many arguments} { + list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4] +} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}} + +test scope-2.4 {code command appends arguments as list elements} { + list [itcl::code "foo bar"] \ + [itcl::code "foo bar" "hello, world!" "one, two, three"] +} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}} + +test scope-2.5 {code command inside code command} { + itcl::code [itcl::code arg1 arg2] arg3 +} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}} + +test scope-2.6 {code command returns fully qualified names} { + namespace eval test_scope_ns { + namespace eval child { + itcl::code foo bar baz + } + } +} {namespace inscope ::test_scope_ns::child {foo bar baz}} + +test scope-2.7 {code command lets you specify a namespace} { + list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \ + [catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg +} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}} + +test scope-2.8 {last namespace wins} { + itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1 +} {namespace inscope ::test_scope_ns arg1} + +test scope-2.9 {"--" terminates switches} { + list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \ + [catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg + +} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}} + +namespace delete test_scope_ns + +# ---------------------------------------------------------------------- +# Test code/scope commands in a class +# ---------------------------------------------------------------------- +test scope-3.1 {define simple classes with things to export} { + itcl::class test_scope { + private variable priv "private-value" + protected variable prov "protected-value" + public variable pubv "public-value" + + private common pric "private-common-value" + protected common proc "protected-common-value" + public common pubc "public-common-value" + + variable varray + common carray + + method mcontext {args} { + return [eval $args] + } + proc pcontext {args} { + return [eval $args] + } + + private method prim {args} { + return "prim: $args" + } + protected method prom {args} { + return "prom: $args" + } + public method pubm {args} { + return "pubm: $args" + } + } + test_scope #auto +} {test_scope0} + +test scope-3.2 {code command captures only class context} { + list [test_scope0 mcontext itcl::code arg1 arg2] \ + [test_scope::pcontext itcl::code arg1 arg2] +} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}} + +test scope-3.3 {scope command captures class and object context} { + list [test_scope0 mcontext itcl::scope priv] \ + [test_scope::pcontext itcl::scope pric] +} {{@itcl ::test_scope0 ::test_scope::priv} ::test_scope::pric} + +test scope-3.4 {scope command must recognize variable} { + list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg +} {1 {variable "xyzzy" not found in class "::test_scope"}} + +test scope-3.5 {scope command provides access to instance variables} { + set result "" + foreach vname {priv prov pubv} { + lappend result [test_scope0 info variable $vname] + set var [test_scope0 mcontext itcl::scope $vname] + set $var "$vname-new" + lappend result [test_scope0 info variable $vname] + } + set result +} {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}} + +test scope-3.6 {scope command provides access to common variables} { + set result "" + foreach vname {pric proc pubc} { + lappend result [test_scope0 info variable $vname] + set var [test_scope0 mcontext itcl::scope $vname] + set $var "$vname-new" + lappend result [test_scope0 info variable $vname] + } + set result +} {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}} + +test scope-3.7 {code command provides access to methods} { + set result "" + foreach mname {prim prom pubm} { + set cmd [test_scope0 mcontext eval itcl::code \$this $mname] + lappend result $cmd [$cmd 1 2 3] + } + set result +} {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}} + +test scope-3.8 {scope command allows access to slots in an array} { + test_scope0 mcontext set varray(0) "defined" + test_scope::pcontext set carray(0) "defined" + list [catch {test_scope0 mcontext scope varray(0)} msg] $msg \ + [catch {test_scope0 mcontext scope varray(1)} msg] $msg \ + [catch {test_scope::pcontext scope carray(0)} msg] $msg \ + [catch {test_scope::pcontext scope carray(1)} msg] $msg +} {0 {@itcl ::test_scope0 ::test_scope::varray(0)} 0 {@itcl ::test_scope0 ::test_scope::varray(1)} 0 ::test_scope::carray(0) 0 ::test_scope::carray(1)} + +itcl::delete class test_scope + +# ---------------------------------------------------------------------- +# Test code/scope commands in a namespace +# ---------------------------------------------------------------------- +test scope-4.1 {define simple namespace with things to export} { + namespace eval test_scope_ns { + variable array + proc pcontext {args} { + return [eval $args] + } + } + namespace children :: ::test_scope_ns +} {::test_scope_ns} + +test scope-4.2 {scope command allows access to slots in an array} { + test_scope_ns::pcontext set array(0) "defined" + list [catch {test_scope_ns::pcontext scope array(0)} msg] $msg \ + [catch {test_scope_ns::pcontext scope array(1)} msg] $msg +} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)} + +namespace delete test_scope_ns

scope.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: mkindex.itcl =================================================================== --- mkindex.itcl (nonexistent) +++ mkindex.itcl (revision 1765) @@ -0,0 +1,88 @@ +# Test file for: +# auto_mkindex +# +# This file provides example cases for testing the Tcl autoloading +# facility. Things are much more complicated with namespaces and classes. +# The "auto_mkindex" facility can no longer be built on top of a simple +# regular expression parser. It must recognize constructs like this: +# +# namespace eval foo { +# class Internal { ... } +# body Internal::func {x y} { ... } +# namespace eval bar { +# class Another { ... } +# } +# } +# +# Note that class definitions can be nested inside of namespaces. +# +# Copyright (c) 1993-1998 Lucent Technologies, Inc. + +# +# Should be able to handle simple class definitions, even if +# they are prefaced with white space. +# +namespace import blt::* + +class Simple1 { + variable x 0 + public method bump {} {incr x} +} + itcl::class Simple2 { + variable x 0 + public variable by 1 + public method bump {} + } + +itcl_class OldStyle { + public x 0 + method foo {args} {return $args} +} + +itcl::ensemble ens { + part one {x} {} + part two {x y} {} + part three {x y z} {} +} + +# +# Should be able to handle "body" and "configbody" declarations. +# +body Simple2::bump {} {incr x $by} +configbody Simple2::by {if {$by <= 0} {error "bad increment}} + +# +# Should be able to handle class declarations within namespaces, +# even if they have explicit namespace paths. +# +namespace eval buried { + class inside { + variable x 0 + public variable by 1 + public method bump {} + method skip {x y z} {} + proc find {args} {} + } + body inside::bump {} {incr x $by} + configbody inside::by {if {$by <= 0} {error "bad increment}} + + class ::top { + method skip {x y z} {} + method ignore {} {} + public proc find {args} {} + protected proc notice {args} {} + } + + ensemble ens { + part one {x} {} + part two {x y} {} + part three {x y z} {} + } + + namespace eval under { + itcl::class neath { } + } + namespace eval deep { + ::itcl::class within { } + } +}

mkindex.itcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: basic.test =================================================================== --- basic.test (nonexistent) +++ basic.test (revision 1765) @@ -0,0 +1,319 @@ +# +# Basic tests for class definition and method/proc access +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: basic.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} + +# ---------------------------------------------------------------------- +# Simple class definition +# ---------------------------------------------------------------------- +test basic-1.1 {define a simple class} { + itcl::class Counter { + constructor {args} { + incr num + eval configure $args + } + destructor { + incr num -1 + } + + method ++ {} { + return [incr val $by] + } + proc num {} { + return $num + } + public variable by 1 + protected variable val 0 + private common num 0 + } +} "" + +test basic-1.2 {class is now defined} { + find classes Counter +} {Counter} + +test basic-1.3 {access command exists with class name} { + namespace which -command Counter +} {::Counter} + +test basic-1.4 {create a simple object} { + Counter x +} {x} + +test basic-1.5a {object names cannot be duplicated} { + list [catch "Counter x" msg] $msg +} {1 {command "x" already exists in namespace "::"}} + +test basic-1.5b {built-in commands cannot be clobbered} { + list [catch "Counter info" msg] $msg +} {1 {command "info" already exists in namespace "::"}} + +test basic-1.6 {objects have an access command} { + namespace which -command x +} {::x} + +test basic-1.7a {objects are added to the master list} { + find objects x +} {x} + +test basic-1.7b {objects are added to the master list} { + find objects -class Counter x +} {x} + +test basic-1.8 {objects can be deleted} { + list [delete object x] [namespace which -command x] +} {{} {}} + +test basic-1.9 {objects can be recreated with the same name} { + Counter x +} {x} + +test basic-1.10 {objects can be destroyed by deleting their access command} { + rename ::x "" + find objects x +} {} + +# ---------------------------------------------------------------------- +# #auto names +# ---------------------------------------------------------------------- +test basic-2.1 {create an object with an automatic name} { + Counter #auto +} {counter0} + +test basic-2.2 {bury "#auto" within object name} { + Counter x#autoy +} {xcounter1y} + +test basic-2.3 {bury "#auto" within object name} { + Counter a#aut#autob +} {a#autcounter2b} + +test basic-2.4 {"#auto" is smart enough to skip names that are taken} { + Counter counter3 + Counter #auto +} {counter4} + +# ---------------------------------------------------------------------- +# Simple object use +# ---------------------------------------------------------------------- +test basic-3.1 {object access command works} { + Counter c + list [c ++] [c ++] [c ++] +} {1 2 3} + +test basic-3.2 {errors produce usage info} { + list [catch "c xyzzy" msg] $msg +} {1 {bad option "xyzzy": should be one of... + c ++ + c cget -option + c configure ?-option? ?value -option value...? + c isa className}} + +test basic-3.3 {built-in configure can query public variables} { + c configure +} {{-by 1 1}} + +test basic-3.4 {built-in configure can query one public variable} { + c configure -by +} {-by 1 1} + +test basic-3.5 {built-in configure can set public variable} { + list [c configure -by 2] [c cget -by] +} {{} 2} + +test basic-3.6 {configure actually changes public variable} { + list [c ++] [c ++] +} {5 7} + +test basic-3.7 {class procs can be accessed} { + Counter::num +} {6} + +test basic-3.8 {obsolete syntax is no longer allowed} { + list [catch "Counter :: num" msg] $msg +} {1 {syntax "class :: proc" is an anachronism +[incr Tcl] no longer supports this syntax. +Instead, remove the spaces from your procedure invocations: + Counter::num ?args?}} + +# ---------------------------------------------------------------------- +# Classes can be destroyed and redefined +# ---------------------------------------------------------------------- +test basic-4.1 {classes can be destroyed} { + list [delete class Counter] \ + [find classes Counter] \ + [namespace children :: Counter] \ + [namespace which -command Counter] +} {{} {} {} {}} + +test basic-4.2 {classes can be redefined} { + itcl::class Counter { + method ++ {} { + return [incr val $by] + } + public variable by 1 + protected variable val 0 + } +} {} + +test basic-4.3 {the redefined class is actually different} { + list [catch "Counter::num" msg] $msg +} {1 {invalid command name "Counter::num"}} + +test basic-4.4 {objects can be created from the new class} { + list [Counter #auto] [Counter #auto] +} {counter0 counter1} + +test basic-4.5 {when a class is destroyed, its objects are deleted} { + list [lsort [find objects counter*]] \ + [delete class Counter] \ + [lsort [find objects counter*]] +} {{counter0 counter1} {} {}} + +# ---------------------------------------------------------------------- +# Namespace variables +# ---------------------------------------------------------------------- +test basic-5.1 {define a simple class with variables in the namespace} { + itcl::class test_globals { + common g1 "global1" + proc getval {name} { + variable $name + return [set [namespace tail $name]] + } + proc setval {name val} { + variable $name + return [set [namespace tail $name] $val] + } + method do {args} { + return [eval $args] + } + } + namespace eval test_globals { + variable g2 "global2" + } +} "" + +test basic-5.2 {create an object for the tests} { + test_globals #auto +} {test_globals0} + +test basic-5.3 {common variables live in the namespace} { + lsort [info vars ::test_globals::*] +} {::test_globals::g1 ::test_globals::g2} + +test basic-5.4 {common variables can be referenced transparently} { + list [catch {test_globals0 do set g1} msg] $msg +} {0 global1} + +test basic-5.5 {namespace variables require a declaration} { + list [catch {test_globals0 do set g2} msg] $msg +} {1 {can't read "g2": no such variable}} + +test basic-5.6a {variable accesses variables within namespace} { + list [catch {test_globals::getval g1} msg] $msg +} {0 global1} + +test basic-5.6a {variable accesses variables within namespace} { + list [catch {test_globals::getval g2} msg] $msg +} {0 global2} + +test basic-5.7 {variable command will not find vars in other namespaces} { + set ::test_global_0 "g0" + list [catch {test_globals::getval test_global_0} msg] $msg \ + [catch {test_globals::getval ::test_global_0} msg] $msg \ +} {1 {can't read "test_global_0": no such variable} 0 g0} + +test basic-5.8 {to create globals in a namespace, use the full path} { + test_globals::setval ::test_global_1 g1 + namespace eval :: {lsort [info globals test_global_*]} +} {test_global_0 test_global_1} + +test basic-5.9 {variable names can have ":" in them} { + test_globals::setval ::test:global:2 g2 + namespace eval :: {info globals test:global:2} +} {test:global:2} + +# ---------------------------------------------------------------------- +# Array variables +# ---------------------------------------------------------------------- +test basic-6.1 {set up a class definition with array variables} { + proc test_arrays_get {name} { + upvar $name x + set rlist {} + foreach index [lsort [array names x]] { + lappend rlist [list $index $x($index)] + } + return $rlist + } + itcl::class test_arrays { + variable nums + common undefined + + common colors + set colors(red) #ff0000 + set colors(green) #00ff00 + set colors(blue) #0000ff + + constructor {} { + set nums(one) 1 + set nums(two) 2 + set nums(three) 3 + + set undefined(a) A + set undefined(b) B + } + method do {args} { + return [eval $args] + } + } + test_arrays #auto +} {test_arrays0} + +test basic-6.2 {test array access for instance variables} { + lsort [test_arrays0 do array get nums] +} {1 2 3 one three two} + +test basic-6.3 {test array access for commons} { + lsort [test_arrays0 do array get colors] +} {#0000ff #00ff00 #ff0000 blue green red} + +test basic-6.4 {test array access for instance variables via "upvar"} { + test_arrays0 do test_arrays_get nums +} {{one 1} {three 3} {two 2}} + +test basic-6.5 {test array access for commons via "upvar"} { + test_arrays0 do test_arrays_get colors +} {{blue #0000ff} {green #00ff00} {red #ff0000}} + +test basic-6.6a {test array access for commons defined in constructor} { + lsort [test_arrays0 do array get undefined] +} {A B a b} + +test basic-6.6b {test array access for commons defined in constructor} { + test_arrays0 do test_arrays_get undefined +} {{a A} {b B}} + +test basic-6.6c {test array access for commons defined in constructor} { + list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)] +} {A B} + +test basic-6.7 {common variables can be unset} { + test_arrays0 do unset undefined + test_arrays0 do array names undefined +} {} + +test basic-6.8 {common variables can be redefined} { + test_arrays0 do set undefined "scalar" +} {scalar}

basic.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: chain.test =================================================================== --- chain.test (nonexistent) +++ chain.test (revision 1765) @@ -0,0 +1,148 @@ +# +# Tests for chaining methods and procs +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: chain.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} + +# ---------------------------------------------------------------------- +# Chaining methods and procs +# ---------------------------------------------------------------------- +test chain-1.1 {define simple classes with inheritance} { + itcl::class test_chain_a { + constructor {args} { + eval chain $args + } { + global ::test_chain_status + lappend test_chain_status "a::constructor $args" + } + method show {mesg} { + chain $mesg + global ::test_chain_status + lappend test_chain_status "a::show $mesg" + } + proc tell {mesg} { + global ::test_chain_status + lappend test_chain_status "a::tell $mesg" + chain $mesg + } + } + itcl::class test_chain_b { + constructor {args} { + eval chain $args + } { + global ::test_chain_status + lappend test_chain_status "b::constructor $args" + } + method show {mesg} { + chain $mesg + global ::test_chain_status + lappend test_chain_status "b::show $mesg" + } + proc tell {mesg} { + global ::test_chain_status + lappend test_chain_status "b::tell $mesg" + chain $mesg + } + } + itcl::class test_chain_c { + inherit test_chain_a test_chain_b + constructor {args} { + eval chain $args + } { + global ::test_chain_status + lappend test_chain_status "c::constructor $args" + } + proc tell {mesg} { + global ::test_chain_status + lappend test_chain_status "c::tell $mesg" + chain $mesg + } + } + itcl::class test_chain_d { + inherit test_chain_c + constructor {args} { + eval chain $args + } { + global ::test_chain_status + lappend test_chain_status "d::constructor $args" + } + method show {mesg} { + chain $mesg + global ::test_chain_status + lappend test_chain_status "d::show $mesg" + } + proc tell {mesg} { + global ::test_chain_status + lappend test_chain_status "d::tell $mesg" + chain $mesg + } + } +} "" + +test chain-1.2 {create a test object} { + set test_chain_status "" + set testobj [test_chain_d #auto 1 2 3] + set test_chain_status +} {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}} + +test chain-1.3 {invoke a chained method} { + set test_chain_status "" + $testobj show "hello there" + set test_chain_status +} {{b::show hello there} {a::show hello there} {d::show hello there}} + +test chain-1.4 {invoke a chained method with a specific name} { + set test_chain_status "" + $testobj test_chain_d::show "hello there" + set test_chain_status +} {{b::show hello there} {a::show hello there} {d::show hello there}} + +test chain-1.5 {chained methods can cross multiple-inheritance branches} { + set test_chain_status "" + $testobj test_chain_a::show "hello there" + set test_chain_status +} {{b::show hello there} {a::show hello there}} + +test chain-1.6 {invoke a chained proc} { + set test_chain_status "" + test_chain_d::tell "testing 1 2 3" + set test_chain_status +} {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}} + +test chain-1.7 {invoke a chained proc} { + set test_chain_status "" + test_chain_c::tell "testing 1 2 3" + set test_chain_status +} {{c::tell testing 1 2 3} {a::tell testing 1 2 3}} + +test chain-2.1 {create a test object in a base class} { + set test_chain_status "" + set testobj [test_chain_c #auto 4 5 6] + set test_chain_status +} {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}} + +test chain-2.2 {invoke a chained method} { + set test_chain_status "" + $testobj show "hello there" + set test_chain_status +} {{b::show hello there} {a::show hello there}} + +test chain-3.0 {invoke "chain" outside of a class} { + list [catch {itcl::builtin::chain 1 2 3} err] $err +} {1 {cannot chain functions outside of a class context}} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +delete class test_chain_d test_chain_c test_chain_b test_chain_a

chain.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: protection.test =================================================================== --- protection.test (nonexistent) +++ protection.test (revision 1765) @@ -0,0 +1,370 @@ +# +# Tests for method/variable protection and access +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: protection.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} + +# ---------------------------------------------------------------------- +# Class members are protected by access restrictions +# ---------------------------------------------------------------------- +test protect-1.1 {define a class with various protection levels} { + itcl::class test_pr { + public { + variable pubv "public var" + common pubc "public com" + method pubm {} {return "public method"} + method ovpubm {} {return "overloaded public method"} + proc pubp {} {return "public proc"} + } + protected { + variable prov "protected var" + common proc "protected com" + method prom {} {return "protected method"} + method ovprom {} {return "overloaded protected method"} + proc prop {} {return "protected proc"} + } + private { + variable priv "private var" + common pric "private com" + method prim {} {return "private method"} + method ovprim {} {return "overloaded private method"} + proc prip {} {return "private proc"} + } + method do {args} {eval $args} + } +} "" + +test protect-1.2 {create an object to execute tests} { + test_pr #auto +} {test_pr0} + +test protect-1.3a {public methods can be accessed from outside} { + list [catch {test_pr0 pubm} msg] $msg +} {0 {public method}} + +test protect-1.3b {public methods can be accessed from inside} { + list [catch {test_pr0 do pubm} msg] $msg +} {0 {public method}} + +test protect-1.4a {protected methods are blocked from outside} { + list [catch {test_pr0 prom} msg] $msg +} {1 {bad option "prom": should be one of... + test_pr0 cget -option + test_pr0 configure ?-option? ?value -option value...? + test_pr0 do ?arg arg ...? + test_pr0 isa className + test_pr0 ovpubm + test_pr0 pubm}} + +test protect-1.4b {protected methods can be accessed from inside} { + list [catch {test_pr0 do prom} msg] $msg +} {0 {protected method}} + +test protect-1.5a {private methods are blocked from outside} { + list [catch {test_pr0 prim} msg] $msg +} {1 {bad option "prim": should be one of... + test_pr0 cget -option + test_pr0 configure ?-option? ?value -option value...? + test_pr0 do ?arg arg ...? + test_pr0 isa className + test_pr0 ovpubm + test_pr0 pubm}} + +test protect-1.5b {private methods can be accessed from inside} { + list [catch {test_pr0 do prim} msg] $msg +} {0 {private method}} + +test protect-1.6a {public procs can be accessed from outside} { + list [catch {test_pr::pubp} msg] $msg +} {0 {public proc}} + +test protect-1.6b {public procs can be accessed from inside} { + list [catch {test_pr0 do pubp} msg] $msg +} {0 {public proc}} + +test protect-1.7a {protected procs are blocked from outside} { + list [catch {test_pr::prop} msg] $msg +} {1 {can't access "::test_pr::prop": protected function}} + +test protect-1.7b {protected procs can be accessed from inside} { + list [catch {test_pr0 do prop} msg] $msg +} {0 {protected proc}} + +test protect-1.8a {private procs are blocked from outside} { + list [catch {test_pr::prip} msg] $msg +} {1 {can't access "::test_pr::prip": private function}} + +test protect-1.8b {private procs can be accessed from inside} { + list [catch {test_pr0 do prip} msg] $msg +} {0 {private proc}} + +test protect-1.9a {public commons can be accessed from outside} { + list [catch {set test_pr::pubc} msg] $msg +} {0 {public com}} + +test protect-1.9b {public commons can be accessed from inside} { + list [catch {test_pr0 do set pubc} msg] $msg +} {0 {public com}} + +test protect-1.10 {protected commons can be accessed from inside} { + list [catch {test_pr0 do set proc} msg] $msg +} {0 {protected com}} + +test protect-1.11 {private commons can be accessed from inside} { + list [catch {test_pr0 do set pric} msg] $msg +} {0 {private com}} + +test protect-1.12a {object-specific variables require an access command} { + list [catch {set test_pr::pubv} msg] $msg +} {1 {can't read "test_pr::pubv": no such variable}} + +test protect-1.12b {public variables can be accessed from inside} { + list [catch {test_pr0 do set pubv} msg] $msg +} {0 {public var}} + +test protect-1.13a {object-specific variables require an access command} { + list [catch {set test_pr::prov} msg] $msg +} {1 {can't read "test_pr::prov": no such variable}} + +test protect-1.13b {protected variables can be accessed from inside} { + list [catch {test_pr0 do set prov} msg] $msg +} {0 {protected var}} + +test protect-1.14a {object-specific variables require an access command} { + list [catch {set test_pr::priv} msg] $msg +} {1 {can't read "test_pr::priv": no such variable}} + +test protect-1.14b {private variables can be accessed from inside} { + list [catch {test_pr0 do set priv} msg] $msg +} {0 {private var}} + +# ---------------------------------------------------------------------- +# Access restrictions work properly with inheritance +# ---------------------------------------------------------------------- +test protect-2.1 {define a derived class} { + itcl::class test_pr_derived { + inherit test_pr + method do {args} {eval $args} + + public method ovpubm {} {return "specific public method"} + protected method ovprom {} {return "specific protected method"} + private method ovprim {} {return "specific private method"} + + public method dpubm {} {return "pub (only in derived)"} + protected method dprom {} {return "pro (only in derived)"} + private method dprim {} {return "pri (only in derived)"} + } +} "" + +test protect-2.2 {create an object to execute tests} { + test_pr_derived #auto +} {test_pr_derived0} + +test protect-2.3 {public methods can be accessed from inside} { + list [catch {test_pr_derived0 do pubm} msg] $msg +} {0 {public method}} + +test protect-2.4 {protected methods can be accessed from inside} { + list [catch {test_pr_derived0 do prom} msg] $msg +} {0 {protected method}} + +test protect-2.5 {private methods are blocked} { + list [catch {test_pr_derived0 do prim} msg] $msg +} {1 {invalid command name "prim"}} + +test protect-2.6 {public procs can be accessed from inside} { + list [catch {test_pr_derived0 do pubp} msg] $msg +} {0 {public proc}} + +test protect-2.7 {protected procs can be accessed from inside} { + list [catch {test_pr_derived0 do prop} msg] $msg +} {0 {protected proc}} + +test protect-2.8 {private procs are blocked} { + list [catch {test_pr_derived0 do prip} msg] $msg +} {1 {invalid command name "prip"}} + +test protect-2.9 {public commons can be accessed from inside} { + list [catch {test_pr_derived0 do set pubc} msg] $msg +} {0 {public com}} + +test protect-2.10 {protected commons can be accessed from inside} { + list [catch {test_pr_derived0 do set proc} msg] $msg +} {0 {protected com}} + +test protect-2.11 {private commons are blocked} { + list [catch {test_pr_derived0 do set pric} msg] $msg +} {1 {can't read "pric": no such variable}} + +test protect-2.12 {public variables can be accessed from inside} { + list [catch {test_pr_derived0 do set pubv} msg] $msg +} {0 {public var}} + +test protect-2.13 {protected variables can be accessed from inside} { + list [catch {test_pr_derived0 do set prov} msg] $msg +} {0 {protected var}} + +test protect-2.14 {private variables are blocked} { + list [catch {test_pr_derived0 do set priv} msg] $msg +} {1 {can't read "priv": no such variable}} + +test protect-2.15 {can access overloaded public method} { + set cmd {namespace eval test_pr_derived {test_pr_derived0 ovpubm}} + list [catch $cmd msg] $msg +} {0 {specific public method}} + +test protect-2.16 {can access overloaded public method} { + set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprom}} + list [catch $cmd msg] $msg +} {0 {specific protected method}} + +test protect-2.17 {can access overloaded private method} { + set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprim}} + list [catch $cmd msg] $msg +} {0 {specific private method}} + +test protect-2.18 {can access overloaded public method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 ovpubm}} + list [catch $cmd msg] $msg +} {0 {specific public method}} + +test protect-2.19 {can access overloaded protected method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 ovprom}} + list [catch $cmd msg] $msg +} {0 {specific protected method}} + +test protect-2.20 {*cannot* access overloaded private method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 ovprim}} + list [catch $cmd msg] $msg +} {1 {bad option "ovprim": should be one of... + test_pr_derived0 cget -option + test_pr_derived0 configure ?-option? ?value -option value...? + test_pr_derived0 do ?arg arg ...? + test_pr_derived0 dpubm + test_pr_derived0 isa className + test_pr_derived0 ovprom + test_pr_derived0 ovpubm + test_pr_derived0 prim + test_pr_derived0 prom + test_pr_derived0 pubm}} + +test protect-2.21 {can access non-overloaded public method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 dpubm}} + list [catch $cmd msg] $msg +} {0 {pub (only in derived)}} + +test protect-2.22 {*cannot* access non-overloaded protected method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 dprom}} + list [catch $cmd msg] $msg +} {1 {bad option "dprom": should be one of... + test_pr_derived0 cget -option + test_pr_derived0 configure ?-option? ?value -option value...? + test_pr_derived0 do ?arg arg ...? + test_pr_derived0 dpubm + test_pr_derived0 isa className + test_pr_derived0 ovprom + test_pr_derived0 ovpubm + test_pr_derived0 prim + test_pr_derived0 prom + test_pr_derived0 pubm}} + +test protect-2.23 {*cannot* access non-overloaded private method from base class} { + set cmd {namespace eval test_pr {test_pr_derived0 dprim}} + list [catch $cmd msg] $msg +} {1 {bad option "dprim": should be one of... + test_pr_derived0 cget -option + test_pr_derived0 configure ?-option? ?value -option value...? + test_pr_derived0 do ?arg arg ...? + test_pr_derived0 dpubm + test_pr_derived0 isa className + test_pr_derived0 ovprom + test_pr_derived0 ovpubm + test_pr_derived0 prim + test_pr_derived0 prom + test_pr_derived0 pubm}} + +eval namespace delete [find classes test_pr*] + +# ---------------------------------------------------------------------- +# Access restrictions don't mess up "info" +# ---------------------------------------------------------------------- +test protect-3.1 {define a base class with private variables} { + itcl::class test_info_base { + private variable pribv "pribv-value" + private common pribc "pribc-value" + protected variable probv "probv-value" + protected common probc "probc-value" + public variable pubbv "pubbv-value" + public common pubbc "pubbc-value" + } + itcl::class test_info_derived { + inherit test_info_base + private variable pridv "pridv-value" + private common pridc "pridc-value" + } +} "" + +test protect-3.2 {create an object to execute tests} { + test_info_derived #auto +} {test_info_derived0} + +test protect-3.3 {all variables are reported} { + list [catch {test_info_derived0 info variable} msg] [lsort $msg] +} {0 {::test_info_base::pribc ::test_info_base::pribv ::test_info_base::probc ::test_info_base::probv ::test_info_base::pubbc ::test_info_base::pubbv ::test_info_derived::pridc ::test_info_derived::pridv ::test_info_derived::this}} + +test protect-3.4 {private base class variables can be accessed} { + list [catch {test_info_derived0 info variable pribv} msg] $msg +} {0 {private variable ::test_info_base::pribv pribv-value pribv-value}} + +test protect-3.5 {private base class commons can be accessed} { + list [catch {test_info_derived0 info variable pribc} msg] $msg +} {0 {private common ::test_info_base::pribc pribc-value pribc-value}} + +test protect-3.6 {protected base class variables can be accessed} { + list [catch {test_info_derived0 info variable probv} msg] $msg +} {0 {protected variable ::test_info_base::probv probv-value probv-value}} + +test protect-3.7 {protected base class commons can be accessed} { + list [catch {test_info_derived0 info variable probc} msg] $msg +} {0 {protected common ::test_info_base::probc probc-value probc-value}} + +test protect-3.8 {public base class variables can be accessed} { + list [catch {test_info_derived0 info variable pubbv} msg] $msg +} {0 {public variable ::test_info_base::pubbv pubbv-value {} pubbv-value}} + +test protect-3.9 {public base class commons can be accessed} { + list [catch {test_info_derived0 info variable pubbc} msg] $msg +} {0 {public common ::test_info_base::pubbc pubbc-value pubbc-value}} + +test protect-3.10 {private derived class variables can be accessed} { + list [catch {test_info_derived0 info variable pridv} msg] $msg +} {0 {private variable ::test_info_derived::pridv pridv-value pridv-value}} + +test protect-3.11 {private derived class commons can be accessed} { + list [catch {test_info_derived0 info variable pridc} msg] $msg +} {0 {private common ::test_info_derived::pridc pridc-value pridc-value}} + +test protect-3.12 {private base class variables can't be accessed from class} { + list [catch { + namespace eval test_info_derived {info variable pribv} + } msg] $msg +} {1 {cannot access object-specific info without an object context}} + +test protect-3.13 {private base class commons can be accessed from class} { + list [catch { + namespace eval test_info_derived {info variable pribc} + } msg] $msg +} {0 {private common ::test_info_base::pribc pribc-value pribc-value}} + +eval namespace delete [find classes test_info*]

protection.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: local.test =================================================================== --- local.test (nonexistent) +++ local.test (revision 1765) @@ -0,0 +1,66 @@ +# +# Tests for "local" command for creating objects local to a proc +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: local.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} + +# ---------------------------------------------------------------------- +# Test "local" to create objects that only exist within a proc +# ---------------------------------------------------------------------- +test local-1.1 {define a class to use for testing} { + class test_local { + common status "" + constructor {} { + lappend status "created $this" + } + destructor { + lappend status "deleted $this" + } + proc clear {} { + set status "" + } + proc check {} { + return $status + } + proc test {} { + local test_local #auto + lappend status "processing" + } + proc test2 {} { + local test_local #auto + lappend status "call test..." + test + lappend status "...back" + } + } + test_local #auto +} {test_local0} + +test local-1.2 {} { + test_local::clear + test_local::test + test_local::check +} {{created ::test_local::test_local1} processing {deleted ::test_local::test_local1}} + +test local-1.3 {} { + test_local::clear + test_local::test2 + test_local::check +} {{created ::test_local::test_local2} {call test...} {created ::test_local::test_local3} processing {deleted ::test_local::test_local3} ...back {deleted ::test_local::test_local2}} + +test local-1.4 {} { + find objects -isa test_local +} {test_local0} + +delete class test_local

local.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: ensemble.test =================================================================== --- ensemble.test (nonexistent) +++ ensemble.test (revision 1765) @@ -0,0 +1,185 @@ +# +# Tests for the "ensemble" compound command facility +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: ensemble.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} + +test ensemble-1.1 {ensemble name must be specified} { + list [catch {ensemble} msg] $msg +} {1 {wrong # args: should be "ensemble name ?command arg arg...?"}} + +test ensemble-1.2 {creating a new ensemble} { + ensemble test_numbers { + part one {x} { + return "one: $x" + } + part two {x y} { + return "two: $x $y" + } + } +} "" +test ensemble-1.3 {adding to an existing ensemble} { + ensemble test_numbers part three {x y z} { + return "three: $x $y $z" + } +} "" + +test ensemble-1.4 {invoking ensemble parts} { + list [test_numbers one 1] [test_numbers two 2 3] [test_numbers three 3 4 5] +} {{one: 1} {two: 2 3} {three: 3 4 5}} + +test ensemble-1.5 {invoking parts with improper arguments} { + list [catch "test_numbers three x" msg] $msg +} {1 {no value given for parameter "y" to "test_numbers three"}} + +test ensemble-1.6 {errors trigger a usage summary} { + list [catch "test_numbers foo x y" msg] $msg +} {1 {bad option "foo": should be one of... + test_numbers one x + test_numbers three x y z + test_numbers two x y}} + +test ensemble-1.7 {one part can't overwrite another} { + set cmd { + ensemble test_numbers part three {} { + return "three: new version" + } + } + list [catch $cmd msg] $msg +} {1 {part "three" already exists in ensemble}} + +test ensemble-1.8 {an ensemble can't overwrite another part} { + set cmd { + ensemble test_numbers ensemble three part new {} { + return "three: new version" + } + } + list [catch $cmd msg] $msg +} {1 {part "three" is not an ensemble}} + +test ensemble-1.9 {body errors are handled gracefully} { + list [catch "ensemble test_numbers {foo bar baz}" msg] $msg $errorInfo +} {1 {invalid command name "foo"} {invalid command name "foo" + while executing +"foo bar baz" + ("ensemble" body line 1) + invoked from within +"ensemble test_numbers {foo bar baz}"}} + +test ensemble-1.10 {part errors are handled gracefully} { + list [catch "ensemble test_numbers {part foo}" msg] $msg $errorInfo +} {1 {wrong # args: should be "part name args body"} {wrong # args: should be "part name args body" + while executing +"part foo" + ("ensemble" body line 1) + invoked from within +"ensemble test_numbers {part foo}"}} + +test ensemble-1.11 {part argument errors are handled gracefully} { + list [catch "ensemble test_numbers {part foo {{}} {}}" msg] $msg $errorInfo +} {1 {procedure "foo" has argument with no name} {procedure "foo" has argument with no name + while executing +"part foo {{}} {}" + ("ensemble" body line 1) + invoked from within +"ensemble test_numbers {part foo {{}} {}}"}} + +test ensemble-2.0 {defining subensembles} { + ensemble test_numbers { + ensemble hex { + part base {} { + return 16 + } + part digits {args} { + foreach num $args { + lappend result "0x$num" + } + return $result + } + } + ensemble octal { + part base {} { + return 8 + } + part digits {{prefix 0} args} { + foreach num $args { + lappend result "$prefix$num" + } + return $result + } + } + } + list [catch "test_numbers foo" msg] $msg +} {1 {bad option "foo": should be one of... + test_numbers hex option ?arg arg ...? + test_numbers octal option ?arg arg ...? + test_numbers one x + test_numbers three x y z + test_numbers two x y}} + +test ensemble-2.1 {invoking sub-ensemble parts} { + list [catch "test_numbers hex base" msg] $msg +} {0 16} + +test ensemble-2.2 {invoking sub-ensemble parts} { + list [catch "test_numbers hex digits 3 a f" msg] $msg +} {0 {0x3 0xa 0xf}} + +test ensemble-2.3 {errors from sub-ensembles} { + list [catch "test_numbers hex" msg] $msg +} {1 {wrong # args: should be one of... + test_numbers hex base + test_numbers hex digits ?arg arg ...?}} + +test ensemble-2.4 {invoking sub-ensemble parts} { + list [catch "test_numbers octal base" msg] $msg +} {0 8} + +test ensemble-2.5 {invoking sub-ensemble parts} { + list [catch "test_numbers octal digits 0o 3 5 10" msg] $msg +} {0 {0o3 0o5 0o10}} + +test ensemble-2.6 {errors from sub-ensembles} { + list [catch "test_numbers octal" msg] $msg +} {1 {wrong # args: should be one of... + test_numbers octal base + test_numbers octal digits ?prefix? ?arg arg ...?}} + +test ensemble-2.7 {sub-ensembles can't be accidentally redefined} { + set cmd { + ensemble test_numbers part octal {args} { + return "octal: $args" + } + } + list [catch $cmd msg] $msg +} {1 {part "octal" already exists in ensemble}} + +test ensemble-3.0 {an error handler part can be used to handle errors} { + ensemble test_numbers { + part @error {args} { + return "error: $args" + } + } + list [catch {test_numbers foo 1 2 3} msg] $msg +} {0 {error: foo 1 2 3}} + +test ensemble-3.1 {the error handler part shows up as generic "...and"} { + list [catch {test_numbers} msg] $msg +} {1 {wrong # args: should be one of... + test_numbers hex option ?arg arg ...? + test_numbers octal option ?arg arg ...? + test_numbers one x + test_numbers three x y z + test_numbers two x y +...and others described on the man page}}

ensemble.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: all =================================================================== --- all (nonexistent) +++ all (revision 1765) @@ -0,0 +1,16 @@ +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "source all" when running tclTest +# in this directory. +# +# SCCS: @(#) all 1.7 96/02/16 08:55:38 + +foreach i [lsort [glob *.test]] { + if [string match l.*.test $i] { + # This is an SCCS lock file; ignore it. + continue + } + puts stdout $i + if [catch {source $i} msg] { + puts $msg + } +}

all Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: info.test =================================================================== --- info.test (nonexistent) +++ info.test (revision 1765) @@ -0,0 +1,384 @@ +# +# Tests for information accessed by the "info" command +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: info.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} + +# ---------------------------------------------------------------------- +# Class definition with one of everything +# ---------------------------------------------------------------------- +test info-1.1 {define a simple class} { + class test_info_base { + method base {} {return "default"} + variable base {} + + method do {args} {eval $args} + } + class test_info { + inherit test_info_base + + constructor {args} { + foreach v [info variable] { + catch {set $v "new-[set $v]"} + } + } + destructor {} + + method defm {} {return "default method"} + public method pubm {x} {return "public method"} + protected method prom {x y} {return "protected method"} + private method prim {x y z} {return "private method"} + + proc defp {} {return "default proc"} + public proc pubp {x} {return "public proc"} + protected proc prop {x y} {return "protected proc"} + private proc prip {x y z} {return "private proc"} + + variable defv "default" + public variable pubv "public" {set pubv "public: $pubv"} + protected variable prov "protected" + private variable priv "private" + + common defc "default" + public common pubc "public" + protected common proc "protected" + private common pric "private" + + method uninitm + proc uninitp {x y} + variable uninitv + common uninitc + set uninitc(0) zero + set uninitc(1) one + } +} "" + +test info-1.2 {info: errors trigger usage info} { + list [catch {namespace eval test_info {info}} msg] $msg +} {1 {wrong # args: should be one of... + info args procname + info body procname + info class + info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? + info heritage + info inherit + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? +...and others described on the man page}} + +test basic-1.3 {info: errors trigger usage info} { + test_info ti + list [catch {ti info} msg] $msg +} {1 {wrong # args: should be one of... + info args procname + info body procname + info class + info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? + info heritage + info inherit + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? +...and others described on the man page}} + +# ---------------------------------------------------------------------- +# Data members +# ---------------------------------------------------------------------- +test info-2.1 {info: all variables} { + lsort [ti info variable] +} {::test_info::defc ::test_info::defv ::test_info::pric ::test_info::priv ::test_info::proc ::test_info::prov ::test_info::pubc ::test_info::pubv ::test_info::this ::test_info::uninitc ::test_info::uninitv ::test_info_base::base} + +test info-2.2a {info: public variables} { + ti info variable pubv +} {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} + +test info-2.2b {info: public variables} { + list [ti info variable pubv -protection] \ + [ti info variable pubv -type] \ + [ti info variable pubv -name] \ + [ti info variable pubv -init] \ + [ti info variable pubv -config] \ + [ti info variable pubv -value] \ +} {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} + +test info-2.3a {info: protected variables} { + ti info variable prov +} {protected variable ::test_info::prov protected new-protected} + +test info-2.3b {info: protected variables} { + list [ti info variable prov -protection] \ + [ti info variable prov -type] \ + [ti info variable prov -name] \ + [ti info variable prov -init] \ + [ti info variable prov -value] \ +} {protected variable ::test_info::prov protected new-protected} + +test info-2.4a {info: private variables} { + ti info variable priv +} {private variable ::test_info::priv private new-private} + +test info-2.4b {info: private variables} { + list [ti info variable priv -protection] \ + [ti info variable priv -type] \ + [ti info variable priv -name] \ + [ti info variable priv -init] \ + [ti info variable priv -value] \ +} {private variable ::test_info::priv private new-private} + +test info-2.5 {"this" variable is built in} { + ti info variable this +} {protected variable ::test_info::this ::ti ::ti} + +test info-2.6 {info: protected/private variables have no "config" code} { + list [ti info variable prov -config] [ti info variable priv -config] +} {{} {}} + +test info-2.7 {by default, variables are "protected"} { + ti info variable defv +} {protected variable ::test_info::defv default new-default} + +test info-2.8 {data members may be uninitialized} { + ti info variable uninitv +} {protected variable ::test_info::uninitv } + +test info-2.9a {info: public common variables} { + ti info variable pubc +} {public common ::test_info::pubc public new-public} + +test info-2.9b {info: public common variables} { + list [ti info variable pubc -protection] \ + [ti info variable pubc -type] \ + [ti info variable pubc -name] \ + [ti info variable pubc -init] \ + [ti info variable pubc -value] \ +} {public common ::test_info::pubc public new-public} + +test info-2.10a {info: protected common variables} { + ti info variable proc +} {protected common ::test_info::proc protected new-protected} + +test info-2.10b {info: protected common variables} { + list [ti info variable proc -protection] \ + [ti info variable proc -type] \ + [ti info variable proc -name] \ + [ti info variable proc -init] \ + [ti info variable proc -value] \ +} {protected common ::test_info::proc protected new-protected} + +test info-2.11a {info: private common variables} { + ti info variable pric +} {private common ::test_info::pric private new-private} + +test info-2.11b {info: private common variables} { + list [ti info variable pric -protection] \ + [ti info variable pric -type] \ + [ti info variable pric -name] \ + [ti info variable pric -init] \ + [ti info variable pric -value] \ +} {private common ::test_info::pric private new-private} + +test info-2.12 {info: public/protected/private vars have no "config" code} { + list [ti info variable pubc -config] \ + [ti info variable proc -config] \ + [ti info variable pric -config] +} {{} {} {}} + +test info-2.13 {by default, variables are "protected"} { + ti info variable defc +} {protected common ::test_info::defc default new-default} + +test info-2.14 {data members may be uninitialized} { + ti info variable uninitc +} {protected common ::test_info::uninitc } + +test info-2.15 {common vars can be initialized within class definition} { + list [namespace eval test_info {lsort [array names uninitc]}] \ + [namespace eval test_info {set uninitc(0)}] \ + [namespace eval test_info {set uninitc(1)}] +} {{0 1} zero one} + +test info-2.16 {flag syntax errors} { + list [catch {ti info variable defv -xyzzy} msg] $msg +} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, or -value}} + +# ---------------------------------------------------------------------- +# Member functions +# ---------------------------------------------------------------------- +test basic-3.1 {info: all functions} { + lsort [ti info function] +} {::test_info::constructor ::test_info::defm ::test_info::defp ::test_info::destructor ::test_info::prim ::test_info::prip ::test_info::prom ::test_info::prop ::test_info::pubm ::test_info::pubp ::test_info::uninitm ::test_info::uninitp ::test_info_base::base ::test_info_base::cget ::test_info_base::configure ::test_info_base::do ::test_info_base::isa} + +test info-3.2a {info: public methods} { + ti info function pubm +} {public method ::test_info::pubm x {return "public method"}} + +test info-3.2b {info: public methods} { + list [ti info function pubm -protection] \ + [ti info function pubm -type] \ + [ti info function pubm -name] \ + [ti info function pubm -args] \ + [ti info function pubm -body] +} {public method ::test_info::pubm x {return "public method"}} + +test info-3.3a {info: protected methods} { + ti info function prom +} {protected method ::test_info::prom {x y} {return "protected method"}} + +test info-3.3b {info: protected methods} { + list [ti info function prom -protection] \ + [ti info function prom -type] \ + [ti info function prom -name] \ + [ti info function prom -args] \ + [ti info function prom -body] +} {protected method ::test_info::prom {x y} {return "protected method"}} + +test info-3.4a {info: private methods} { + ti info function prim +} {private method ::test_info::prim {x y z} {return "private method"}} + +test info-3.4b {info: private methods} { + list [ti info function prim -protection] \ + [ti info function prim -type] \ + [ti info function prim -name] \ + [ti info function prim -args] \ + [ti info function prim -body] +} {private method ::test_info::prim {x y z} {return "private method"}} + +test info-3.5 {"configure" function is built in} { + ti info function configure +} {public method ::test_info_base::configure {?-option? ?value -option value...?} @itcl-builtin-configure} + +test info-3.6 {by default, methods are "public"} { + ti info function defm +} {public method ::test_info::defm {} {return "default method"}} + +test info-3.7 {methods may not have arg lists or bodies defined} { + ti info function uninitm +} {public method ::test_info::uninitm } + +test info-3.8a {info: public procs} { + ti info function pubp +} {public proc ::test_info::pubp x {return "public proc"}} + +test info-3.8b {info: public procs} { + list [ti info function pubp -protection] \ + [ti info function pubp -type] \ + [ti info function pubp -name] \ + [ti info function pubp -args] \ + [ti info function pubp -body] +} {public proc ::test_info::pubp x {return "public proc"}} + +test info-3.9a {info: protected procs} { + ti info function prop +} {protected proc ::test_info::prop {x y} {return "protected proc"}} + +test info-3.9b {info: protected procs} { + list [ti info function prop -protection] \ + [ti info function prop -type] \ + [ti info function prop -name] \ + [ti info function prop -args] \ + [ti info function prop -body] +} {protected proc ::test_info::prop {x y} {return "protected proc"}} + +test info-3.10a {info: private procs} { + ti info function prip +} {private proc ::test_info::prip {x y z} {return "private proc"}} + +test info-3.10b {info: private procs} { + list [ti info function prip -protection] \ + [ti info function prip -type] \ + [ti info function prip -name] \ + [ti info function prip -args] \ + [ti info function prip -body] +} {private proc ::test_info::prip {x y z} {return "private proc"}} + +test info-3.11 {by default, procs are "public"} { + ti info function defp +} {public proc ::test_info::defp {} {return "default proc"}} + +test info-3.12 {procs may not have arg lists or bodies defined} { + ti info function uninitp +} {public proc ::test_info::uninitp {x y} } + +test info-3.13 {flag syntax errors} { + list [catch {ti info function defm -xyzzy} msg] $msg +} {1 {bad option "-xyzzy": must be -args, -body, -name, -protection, or -type}} + +# ---------------------------------------------------------------------- +# Other object-related queries +# ---------------------------------------------------------------------- + +test info-4.1a {query class (wrong # args)} { + list [catch {ti info class x} result] $result +} {1 {wrong # args: should be "info class"}} + +test info-4.1b {query most-specific class} { + list [ti info class] [ti do info class] +} {::test_info ::test_info} + +test info-4.2a {query inheritance info (wrong # args)} { + list [catch {ti info inherit x} result] $result +} {1 {wrong # args: should be "info inherit"}} + +test info-4.2b {query inheritance info} { + list [ti info inherit] [ti do info inherit] +} {::test_info_base {}} + +test info-4.3a {query heritage info (wrong # args)} { + list [catch {ti info heritage x} result] $result +} {1 {wrong # args: should be "info heritage"}} + +test info-4.3b {query heritage info} { + list [ti info heritage] [ti do info heritage] +} {{::test_info ::test_info_base} ::test_info_base} + +test info-4.4a {query argument list (wrong # args)} { + list [catch {ti info args} result] $result \ + [catch {ti info args x y} result] $result +} {1 {wrong # args: should be "info args function"} 1 {wrong # args: should be "info args function"}} + +test info-4.4b {query argument list} { + ti info args prim +} {x y z} + +test info-4.4c {query argument list (undefined)} { + ti info args uninitm +} {} + +test info-4.5a {query body (wrong # args)} { + list [catch {ti info body} result] $result \ + [catch {ti info body x y} result] $result +} {1 {wrong # args: should be "info body function"} 1 {wrong # args: should be "info body function"}} + +test info-4.5b {query body} { + ti info body prim +} {return "private method"} + +test info-4.5c {query body (undefined)} { + ti info body uninitm +} {} + +# ---------------------------------------------------------------------- +# Other parts of the usual "info" command +# ---------------------------------------------------------------------- + +test info-5.1 {info vars} { + ti do info vars +} {args} + +test info-5.2 {info exists} { + list [ti do info exists args] [ti do info exists xyzzy] +} {1 0} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +delete class test_info test_info_base

info.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: tclIndex =================================================================== --- tclIndex (nonexistent) +++ tclIndex (revision 1765) @@ -0,0 +1,24 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(Simple1) [list source [file join $dir mkindex.itcl]] +set auto_index(Simple2) [list source [file join $dir mkindex.itcl]] +set auto_index(OldStyle) [list source [file join $dir mkindex.itcl]] +set auto_index(ens) [list source [file join $dir mkindex.itcl]] +set auto_index(::Simple2::bump) [list source [file join $dir mkindex.itcl]] +set auto_index(::Simple2::by) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::inside) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::inside::find) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::inside::bump) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::inside::by) [list source [file join $dir mkindex.itcl]] +set auto_index(top) [list source [file join $dir mkindex.itcl]] +set auto_index(::top::find) [list source [file join $dir mkindex.itcl]] +set auto_index(::top::notice) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::ens) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::under::neath) [list source [file join $dir mkindex.itcl]] +set auto_index(::buried::deep::within) [list source [file join $dir mkindex.itcl]]

tclIndex Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: namespace.test =================================================================== --- namespace.test (nonexistent) +++ namespace.test (revision 1765) @@ -0,0 +1,74 @@ +# +# Tests for classes within namespaces +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: namespace.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} + +# ---------------------------------------------------------------------- +# Classes within namespaces +# ---------------------------------------------------------------------- +test namespace-1.1 {same class name can be used in different namespaces} { + namespace eval test_ns_1 { + class Counter { + variable num 0 + method ++ {{by 1}} { + incr num $by + } + method do {args} { + return [eval $args] + } + common tag 1 + } + } + namespace eval test_ns_2 { + class Counter { + variable num 0 + method ++ {{by 2}} { + if {$num == 0} { + set num 1 + } else { + set num [expr $num*$by] + } + } + method do {args} { + return [eval $args] + } + common tag 2 + } + } +} "" + +test namespace-1.2 {classes in different namespaces are different} { + list [namespace eval test_ns_1::Counter {info variable tag}] \ + [namespace eval test_ns_2::Counter {info variable tag}] \ +} {{protected common ::test_ns_1::Counter::tag 1 1} {protected common ::test_ns_2::Counter::tag 2 2}} + +test namespace-1.3 {create an object in one namespace} { + namespace eval test_ns_1 { + list [Counter c] [c ++] [c ++] [c ++] [c ++] + } +} {c 1 2 3 4} + +test namespace-1.4 {create an object in another namespace} { + namespace eval test_ns_2 { + list [Counter c] [c ++] [c ++] [c ++] [c ++] + } +} {c 1 2 4 8} + +test namespace-1.5 {can find classes wrapped in a namespace} { + list [catch {test_ns_1::c do find objects -isa Counter} msg] $msg \ + [catch {test_ns_1::c do find objects -class Counter} msg] $msg +} {0 {} 0 {}} + +namespace delete test_ns_1 test_ns_2

namespace.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: body.test =================================================================== --- body.test (nonexistent) +++ body.test (revision 1765) @@ -0,0 +1,218 @@ +# +# Tests for "body" and "configbody" commands +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: body.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} + +# ---------------------------------------------------------------------- +# Test "body" command +# ---------------------------------------------------------------------- +test body-1.1 {define a class with missing bodies and arg lists} { + class test_body { + constructor {args} {} + destructor {} + + method any + method zero {} + method one {x} + method two {x y} + method defvals {x {y 0} {z 1}} + method varargs {x args} + + method override {mesg} { + return "override: $mesg" + } + } +} "" + +test body-1.2 {cannot use methods without a body} { + test_body #auto + list [catch "test_body0 any" msg] $msg +} {1 {member function "::test_body::any" is not defined and cannot be autoloaded}} + +test body-1.3 {check syntax of "body" command} { + list [catch "body test_body::any" msg] $msg +} {1 {wrong # args: should be "body class::func arglist body"}} + +test body-1.4 {make sure members are found correctly} { + list [catch "body test_body::xyzzyxyzzyxyzzy {} {}" msg] $msg +} {1 {function "xyzzyxyzzyxyzzy" is not defined in class "::test_body"}} + +test body-1.5a {members without an argument list can have any args} { + body test_body::any {} {return "any"} + list [catch "test_body0 any" msg] $msg +} {0 any} + +test body-1.5b {members without an argument list can have any args} { + body test_body::any {x} {return "any: $x"} + list [catch "test_body0 any 1" msg] $msg +} {0 {any: 1}} + +test body-1.5c {members without an argument list can have any args} { + body test_body::any {x {y 2}} {return "any: $x $y"} + list [catch "test_body0 any 1" msg] $msg +} {0 {any: 1 2}} + +test body-1.6a {an empty argument list must stay empty} { + list [catch {body test_body::zero {x y} {return "zero: $x $y"}} msg] $msg +} {1 {argument list changed for function "::test_body::zero": should be ""}} + +test body-1.6b {an empty argument list must stay empty} { + list [catch {body test_body::zero {} {return "zero"}} msg] $msg +} {0 {}} + +test body-1.7a {preserve argument list: fixed arguments} { + list [catch {body test_body::one {x y} {return "one: $x $y"}} msg] $msg +} {1 {argument list changed for function "::test_body::one": should be "x"}} + +test body-1.7b {preserve argument list: fixed arguments} { + list [catch {body test_body::one {a} {return "one: $a"}} msg] $msg +} {0 {}} + +test body-1.7c {preserve argument list: fixed arguments} { + list [catch "test_body0 one 1.0" msg] $msg +} {0 {one: 1.0}} + +test body-1.8a {preserve argument list: fixed arguments} { + list [catch {body test_body::two {x} {return "two: $x"}} msg] $msg +} {1 {argument list changed for function "::test_body::two": should be "x y"}} + +test body-1.8b {preserve argument list: fixed arguments} { + list [catch {body test_body::two {a b} {return "two: $a $b"}} msg] $msg +} {0 {}} + +test body-1.8c {preserve argument list: fixed arguments} { + list [catch "test_body0 two 2.0 3.0" msg] $msg +} {0 {two: 2.0 3.0}} + +test body-1.9a {preserve argument list: default arguments} { + list [catch {body test_body::defvals {x} {}} msg] $msg +} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} + +test body-1.9b {preserve argument list: default arguments} { + list [catch {body test_body::defvals {a {b 0} {c 2}} {}} msg] $msg +} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} + +test body-1.9c {preserve argument list: default arguments} { + list [catch {body test_body::defvals {a {b 0} {c 1}} {}} msg] $msg +} {0 {}} + +test body-1.10a {preserve argument list: variable arguments} { + list [catch {body test_body::varargs {} {}} msg] $msg +} {1 {argument list changed for function "::test_body::varargs": should be "x args"}} + +test body-1.10b {preserve argument list: variable arguments} { + list [catch {body test_body::varargs {a} {}} msg] $msg +} {0 {}} + +test body-1.10c {preserve argument list: variable arguments} { + list [catch {body test_body::varargs {a b c} {}} msg] $msg +} {0 {}} + +test body-1.11 {redefined body really does change} { + list [test_body0 override "test #1"] \ + [body test_body::override {text} {return "new: $text"}] \ + [test_body0 override "test #2"] +} {{override: test #1} {} {new: test #2}} + +# ---------------------------------------------------------------------- +# Test "body" command with inheritance +# ---------------------------------------------------------------------- +test body-2.1 {inherit from a class with missing bodies} { + class test_ibody { + inherit test_body + method zero {} + } + test_ibody #auto +} {test_ibody0} + +test body-2.2 {redefine a method in a derived class} { + body test_ibody::zero {} {return "ibody zero"} + list [test_ibody0 info function zero] \ + [test_ibody0 info function test_body::zero] +} {{public method ::test_ibody::zero {} {return "ibody zero"}} {public method ::test_body::zero {} {return "zero"}}} + +test body-2.3 {try to redefine a method that was not declared} { + list [catch {body test_ibody::one {x} {return "new"}} msg] $msg +} {1 {function "one" is not defined in class "::test_ibody"}} + +# ---------------------------------------------------------------------- +# Test "configbody" command +# ---------------------------------------------------------------------- +test body-3.1 {define a class with public variables} { + class test_cbody { + private variable priv + protected variable prot + + public variable option {} { + lappend messages "option: $option" + } + public variable nocode {} + public common messages + } +} "" + +test body-3.2 {check syntax of "configbody" command} { + list [catch "configbody test_cbody::option" msg] $msg +} {1 {wrong # args: should be "configbody class::option body"}} + +test body-3.3 {make sure that members are found correctly} { + list [catch "configbody test_cbody::xyzzy {}" msg] $msg +} {1 {option "xyzzy" is not defined in class "::test_cbody"}} + +test body-3.4 {private variables have no config code} { + list [catch "configbody test_cbody::priv {bogus}" msg] $msg +} {1 {option "::test_cbody::priv" is not a public configuration option}} + +test body-3.5 {protected variables have no config code} { + list [catch "configbody test_cbody::prot {bogus}" msg] $msg +} {1 {option "::test_cbody::prot" is not a public configuration option}} + +test body-3.6 {can use public variables without a body} { + test_cbody #auto + list [catch "test_cbody0 configure -nocode 1" msg] $msg +} {0 {}} + +test body-3.7 {redefined body really does change} { + list [test_cbody0 configure -option "hello"] \ + [configbody test_cbody::option {lappend messages "new: $option"}] \ + [test_cbody0 configure -option "goodbye"] \ + [set test_cbody::messages] \ +} {{} {} {} {{option: hello} {new: goodbye}}} + +# ---------------------------------------------------------------------- +# Test "configbody" command with inheritance +# ---------------------------------------------------------------------- +test body-4.1 {inherit from a class with missing config bodies} { + class test_icbody { + inherit test_cbody + public variable option "icbody" + } + test_icbody #auto +} {test_icbody0} + +test body-4.2 {redefine a body in a derived class} { + configbody test_icbody::option {lappend messages "test_icbody: $option"} + list [test_icbody0 info variable option] \ + [test_icbody0 info variable test_cbody::option] +} {{public variable ::test_icbody::option icbody {lappend messages "test_icbody: $option"} icbody} {public variable ::test_cbody::option {} {lappend messages "new: $option"} {}}} + +test body-4.3 {try to redefine a body for a variable that was not declared} { + list [catch {configbody test_icbody::nocode {return "new"}} msg] $msg +} {1 {option "nocode" is not defined in class "::test_icbody"}} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +delete class test_body test_cbody

body.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: mkindex.test =================================================================== --- mkindex.test (nonexistent) +++ mkindex.test (revision 1765) @@ -0,0 +1,44 @@ +# +# Tests for "auto_mkindex" and autoloading facility +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: mkindex.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} + +# ---------------------------------------------------------------------- +# Test "auto_mkindex" in the presence of class definitions +# ---------------------------------------------------------------------- +test mkindex-1.1 {remove any existing tclIndex file} { + file delete tclIndex + file exists tclIndex +} {0} + +test mkindex-1.2 {build tclIndex based on a test file} { + auto_mkindex . mkindex.itcl + file exists tclIndex +} {1} + +set element "{source [file join . mkindex.itcl]}" + +test mkindex-1.3 {examine tclIndex} { + namespace eval itcl_mkindex_tmp { + set dir "." + variable auto_index + source tclIndex + set result "" + foreach elem [lsort [array names auto_index]] { + lappend result [list $elem $auto_index($elem)] + } + set result + } +} "{::Simple2::bump $element} {::Simple2::by $element} {::buried::deep::within $element} {::buried::ens $element} {::buried::inside $element} {::buried::inside::bump $element} {::buried::inside::by $element} {::buried::inside::find $element} {::buried::under::neath $element} {::top::find $element} {::top::notice $element} {OldStyle $element} {Simple1 $element} {Simple2 $element} {ens $element} {top $element}"

mkindex.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/inherit.test =================================================================== --- old/inherit.test (nonexistent) +++ old/inherit.test (revision 1765) @@ -0,0 +1,272 @@ +# +# Tests for inheritance and scope handling +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: inherit.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. + +# ---------------------------------------------------------------------- +# MULTIPLE BASE-CLASS ERROR DETECTION +# ---------------------------------------------------------------------- +test {Cannot inherit from the same base class more than once} { + catch "VirtualErr" errmsg + set errmsg +} { + [string match {*class "::VirtualErr" inherits base class "::Foo" more than once: + VirtualErr->Mongrel->FooBar->Foo + VirtualErr->Foo + VirtualErr->BarFoo->Foo} $result] +} + +# ---------------------------------------------------------------------- +# CONSTRUCTION +# ---------------------------------------------------------------------- +test {Constructors should be invoked implicitly} { + set WATCH "" + concat [Mongrel m] / $WATCH +} { + $result == "m / ::Geek ::Bar ::Foo ::FooBar ::Mongrel" +} + +test {Initialization of shadowed variables works properly} { + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "nonnull / " +} + +# ---------------------------------------------------------------------- +# PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Inherited "config" method works on derived classes} { + m config -blit xyz -Foo::blit pdq +} { + $result == "Mongrel::blit Foo::blit" +} + +test {Inherited "config" method works on derived classes} { + m config -blit xyz -Foo::blit pdq + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "xyz / pdq" +} + +test {Inherited "config" method works on derived classes} { + m config -tag #0000 +} { + $result == "Mongrel::tag" +} + +# ---------------------------------------------------------------------- +# INHERITANCE INFO +# ---------------------------------------------------------------------- +test {Info: class} { + m info class +} { + $result == "::Mongrel" +} + +test {Info: inherit} { + m info inherit +} { + $result == "::FooBar ::Geek" +} + +test {Info: heritage} { + m info heritage +} { + $result == "::Mongrel ::FooBar ::Foo ::Bar ::Geek" +} + +test {Built-in "isa" method} { + set status 1 + foreach c [m info heritage] { + set status [expr {$status && [m isa $c]}] + } + set status +} { + $result == 1 +} + +test {Built-in "isa" method} { + itcl_class Watermelon {} + m isa Watermelon +} { + $result == 0 +} + +# ---------------------------------------------------------------------- +# SCOPE MANIPULATION +# ---------------------------------------------------------------------- +test {commands normally execute in the scope of their class} { + m Foo::do {namespace current} +} { + $result == "Foo says '::Foo'" +} + +test {"virtual" command moves scope to most specific class} { + m Foo::do {virtual namespace current} +} { + $result == "Foo says '::Mongrel'" +} + +test {"previous" command moves scope upward in hierarchy} { + m do {virtual previous namespace current} +} { + $result == "Foo says '::FooBar'" +} + +test {"previous" command can be chained} { + m do {virtual previous previous namespace current} +} { + $result == "Foo says '::Foo'" +} + +# ---------------------------------------------------------------------- +# METHOD INVOCATION +# ---------------------------------------------------------------------- +test {Simple method names are assigned based on heritage} { + m do {concat "$this ([virtual info class]) at scope [namespace current]"} +} { + $result == "Foo says '::m (Mongrel) at scope ::Foo'" +} + +test {Explicit scoping can be used to reach shadowed members} { + m Geek::do {concat "$this ([virtual info class]) at scope [namespace current]"} +} { + $result == "Geek says '::m (Mongrel) at scope ::Geek'" +} + +test {Methods execute in local scope of class, e.g., Foo::do} { + m config -blit abc -Foo::blit def + m Foo::do {set blit xyz} + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "abc / xyz" +} + +# ---------------------------------------------------------------------- +# DESTRUCTION +# ---------------------------------------------------------------------- +test {Destructors should be invoked implicitly} { + set WATCH "" + concat [m delete] / $WATCH +} { + $result == "/ ::Mongrel ::FooBar ::Foo ::Bar ::Geek" +} + +# ---------------------------------------------------------------------- +# OBJECT INFO +# ---------------------------------------------------------------------- +foreach obj [itcl_info objects] { + $obj delete +} +Mongrel m +FooBar fb +Foo f +Geek g + +test {Object queries can be restricted by object name} { + itcl_info objects f* +} { + [test_cmp_lists $result {f fb}] +} + +test {Object queries can be restricted to specific classes} { + itcl_info objects -class Foo +} { + $result == "f" +} + +test {Object queries can be restricted by object heritage} { + itcl_info objects -isa Foo +} { + [test_cmp_lists $result {m f fb}] +} + +test {Object queries can be restricted by object name / specific classes} { + itcl_info objects f* -class Foo +} { + $result == "f" +} + +test {Object queries can be restricted by object name / object heritage} { + itcl_info objects f* -isa Foo +} { + [test_cmp_lists $result {f fb}] +} + +# ---------------------------------------------------------------------- +# ERROR HANDLING ACROSS CLASS BOUNDARIES +# ---------------------------------------------------------------------- +Mongrel m1 +FooBar fb2 + +test {Errors and detected and reported across class boundaries} { + set status [catch {m1 do {fb2 do {error "test"}}} mesg] + format "$mesg $status" +} { + $result == "test 1" +} + +test {Stack trace unwinds properly across class boundaries} { + catch {m1 do {fb2 do {error "test"}}} mesg + format "$errorInfo" +} { + $result == {test + while executing +"error "test"" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::fb2" method "::Foo::do" body line 2) + invoked from within +"fb2 do {error "test"}" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::m1" method "::Foo::do" body line 2) + invoked from within +"m1 do {fb2 do {error "test"}}"} +} + +test {Stack trace unwinds properly across class boundaries} { + catch {m1 do {fb2 do {error "test" "some error"}}} mesg + format "$errorInfo" +} { + $result == {some error + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::fb2" method "::Foo::do" body line 2) + invoked from within +"fb2 do {error "test" "some error"}" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::m1" method "::Foo::do" body line 2) + invoked from within +"m1 do {fb2 do {error "test" "some error"}}"} +} + +test {Error codes are preserved across class boundaries} { + catch {m1 do {fb2 do {error "test" "some error" CODE-BLUE}}} mesg + format "$errorCode" +} { + $result == "CODE-BLUE" +}

old/inherit.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/VirtualErr.tcl =================================================================== --- old/VirtualErr.tcl (nonexistent) +++ old/VirtualErr.tcl (revision 1765) @@ -0,0 +1,23 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: VirtualErr.tcl,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. + +itcl_class VirtualErr { + # + # The following inherit statement will cause an error, + # since it will find the same base class "Foo" inherited + # from several places. + # + inherit Mongrel Foo BarFoo +}

old/VirtualErr.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/Mongrel.tcl =================================================================== --- old/Mongrel.tcl (nonexistent) +++ old/Mongrel.tcl (revision 1765) @@ -0,0 +1,34 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: Mongrel.tcl,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. + +itcl_class Mongrel { + inherit FooBar Geek + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + public blit nonnull + public tag +}

old/Mongrel.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/Bar.tcl =================================================================== --- old/Bar.tcl (nonexistent) +++ old/Bar.tcl (revision 1765) @@ -0,0 +1,39 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: Bar.tcl,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. + +itcl_class Bar { + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + method config {config} { + return $config + } + + # + # Define variables that will be shadowed by another class. + # + public blit + protected _blit +}

old/Bar.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/testlib.tcl =================================================================== --- old/testlib.tcl (nonexistent) +++ old/testlib.tcl (revision 1765) @@ -0,0 +1,131 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: testlib.tcl,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. + +# ---------------------------------------------------------------------- +# USAGE: test

+# +# Executes the given test, the evaluates the condition to +# see if the test passed. The result from the is kept +# in the variable $result. If this condition evaluates non-zero, +# the test has passed. Otherwise, the test has failed. A variety +# if checking routines (test_cmp_*) are provided below to make +# the check condition easier to write. +# ---------------------------------------------------------------------- +proc test {desc cmd check} { + set result [uplevel $cmd] + + if {![expr $check]} { + puts stdout "-------------------------------------------------------" + puts stdout ">>>> FAILED TEST <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" + puts stdout "-------------------------------------------------------" + set lines [split $desc "\n"] + foreach i $lines { + puts stdout $i + } + puts stdout "=======================================================" + set lines [split $cmd "\n"] + set label TEST + foreach i $lines { + puts stdout " $label | $i" + set label " " + } + puts stdout "-------------------------------------------------------" + set lines [split $check "\n"] + set label CHECK + foreach i $lines { + if {$i != ""} { + puts stdout " $label | $i" + set label " " + } + } + puts stdout "-------------------------------------------------------" + set lines [split $result "\n"] + set label RESULT + foreach i $lines { + if {$i != ""} { + puts stdout " $label | \$result => $i" + set label " " + } + } + puts stdout "=======================================================" + error "tests aborted" + } +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_nums +# +# Compares two numbers to see if they are "equal." Numbers are +# "equal" if they have an absolute value greater than 1.0e-6 and they +# have at least 5 significant figures. Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_nums {num1 num2} { + global TEST_ABS_TOL TEST_REL_TOL + + if {[expr abs($num1)] > $TEST_ABS_TOL && + [expr abs($num2)] > $TEST_ABS_TOL} { + set avg [expr 0.5*($num1+$num2)] + set diff [expr abs(($num1-$num2)/$avg)] + + if {$diff > $TEST_REL_TOL} { + return 0 + } + } + return 1 +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_vectors +# +# Compares two lists of numbers to see if they are "equal." Vectors +# are "equal" if elements are "equal" in the numeric sense. +# Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_vectors {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + for {set i 0} {$i < [llength $list1]} {incr i} { + set n1 [lindex $list1 $i] + set n2 [lindex $list2 $i] + + if {![test_cmp_nums $n1 $n2]} { + return 0 + } + } + return 1 +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_lists +# +# Compares two lists to see if they are "equal." Lists are "equal" +# if they contain exactly the same elements, but perhaps in a +# different order. Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_lists {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + foreach elem $list1 { + set i [lsearch $list2 $elem] + if {$i >= 0} { + set list2 [lreplace $list2 $i $i] + } else { + return 0 + } + } + return 1 +}

old/testlib.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/FooBar.tcl =================================================================== --- old/FooBar.tcl (nonexistent) +++ old/FooBar.tcl (revision 1765) @@ -0,0 +1,31 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: FooBar.tcl,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. + +itcl_class FooBar { + inherit Foo Bar + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } +}

old/FooBar.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/BarFoo.tcl =================================================================== --- old/BarFoo.tcl (nonexistent) +++ old/BarFoo.tcl (revision 1765) @@ -0,0 +1,31 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: BarFoo.tcl,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. + +itcl_class BarFoo { + inherit Bar Foo + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } +}

old/BarFoo.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/uplevel.test =================================================================== --- old/uplevel.test (nonexistent) +++ old/uplevel.test (revision 1765) @@ -0,0 +1,155 @@ +# +# Tests for "uplevel" across interpreter boundaries +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: uplevel.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. + +# ---------------------------------------------------------------------- +# DEFINE SOME USEFUL ROUTINES +# ---------------------------------------------------------------------- +proc uplevelTest_show_var {level var} { + return "$var>>[uplevel $level set $var]" +} + +proc uplevelTest_do {cmd} { + eval $cmd +} + +# ---------------------------------------------------------------------- +# CREATE SOME OBJECTS +# ---------------------------------------------------------------------- +Foo foo +Baz baz + +# ---------------------------------------------------------------------- +# UPLEVEL TESTS (main interp) +# ---------------------------------------------------------------------- +test {"uplevel" can access global variables (via relative level)} { + set globalvar "global value" + uplevelTest_show_var 1 globalvar +} { + $result == "globalvar>>global value" +} + +test {"uplevel" can access global variables (via "#0")} { + set globalvar "global value" + uplevelTest_show_var #0 globalvar +} { + $result == "globalvar>>global value" +} + +test {"uplevel" can access local variables (via relative level)} { + uplevelTest_do { + set localvar "local value" + uplevelTest_show_var 1 localvar + } +} { + $result == "localvar>>local value" +} + +test {"uplevel" can access local variables (via relative level)} { + uplevelTest_do { + set localvar "proper value" + uplevelTest_do { + set localvar "not this one" + uplevelTest_show_var 2 localvar + } + } +} { + $result == "localvar>>proper value" +} + +test {"uplevel" can access local variables (via explicit level)} { + uplevelTest_do { + set localvar "local value" + uplevelTest_show_var #1 localvar + } +} { + $result == "localvar>>local value" +} + +# ---------------------------------------------------------------------- +# UPLEVEL TESTS (across class interps) +# ---------------------------------------------------------------------- +test {"uplevel" can cross class interps to access global variables} { + set globalvar "global value" + foo do { + uplevel #0 uplevelTest_show_var 1 globalvar + } +} { + $result == "Foo says 'globalvar>>global value'" +} + +test {"uplevel" can cross several class interps to access global variables} { + set globalvar "global value" + baz do { + foo do { + uplevel 2 uplevelTest_show_var #0 globalvar + } + } +} { + $result == "Baz says 'Foo says 'globalvar>>global value''" +} + +test {"uplevel" finds proper scope for execution} { + baz do { + foo do { + uplevel do {{info class}} + } + } +} { + $result == "Baz says 'Foo says 'Baz says '::Baz'''" +} + +test {"uplevel" finds proper scope for execution, +and works in conjunction with "unknown" to access +commands at the global scope with local call frames} { + baz do { + set bazvar "value in Baz" + foo do { + uplevel ::info locals + } + } +} { + $result == "Baz says 'Foo says 'bazvar cmds''" +} + +# ---------------------------------------------------------------------- +# LEVEL TESTS (across class scopes) +# ---------------------------------------------------------------------- +test {"info level" works across scope boundaries} { + baz do { + foo do { + info level + } + } +} { + $result == "Baz says 'Foo says '2''" +} + +test {"info level" works across scope boundaries} { + baz do { + foo do { + info level 0 + } + } +} { + $result == "Baz says 'Foo says 'do { + info level 0 + }''" +} + +# ---------------------------------------------------------------------- +# CLEAN UP +# ---------------------------------------------------------------------- +foo delete +baz delete

old/uplevel.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/Geek.tcl =================================================================== --- old/Geek.tcl (nonexistent) +++ old/Geek.tcl (revision 1765) @@ -0,0 +1,44 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: Geek.tcl,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. + +itcl_class Geek { + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + method do {cmds} { + return "Geek says '[eval $cmds]'" + } + + method config {config} { + return $config + } + + # + # Define variables that will be shadowed by another class. + # + public blat + protected _blat +}

old/Geek.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/Baz.tcl =================================================================== --- old/Baz.tcl (nonexistent) +++ old/Baz.tcl (revision 1765) @@ -0,0 +1,27 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: Baz.tcl,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. + +itcl_class Baz { + # + # Avoid defining constructor/destructor + # + + # + # Generic method for doing something in "Baz" interp + # + method do {cmds} { + return "Baz says '[eval $cmds]'" + } +}

old/Baz.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toaster.test =================================================================== --- old/toaster.test (nonexistent) +++ old/toaster.test (revision 1765) @@ -0,0 +1,165 @@ +# +# Tests for "toaster" example +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: toaster.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. + +# ---------------------------------------------------------------------- +# Get toaster classes from "demos" directory. +# ---------------------------------------------------------------------- +lappend auto_path toasters + +# ---------------------------------------------------------------------- +# Outlets send bills to an e-mail address. Determine this address. +# ---------------------------------------------------------------------- +if {[info exists env(USER)]} { + set Owner $env(USER) +} elseif {[info exists env(LOGNAME)]} { + set Owner $env(LOGNAME) +} else { + set Owner [exec logname] +} + +# ---------------------------------------------------------------------- +# TOASTERS +# ---------------------------------------------------------------------- +test {Create a toaster and plug it in} { + global Owner + Toaster original -heat 1 -outlet [Outlet #auto -owner $Owner] +} { + $result == "original" +} + +test {Turn up the heat setting on the toaster} { + original config -heat 5 +} { + $result == "" +} + +test {Toast a few slices of bread} { + original toast 2 +} { + $result == "crumb tray: 25% full" +} + +test {Clean the toaster} { + original clean +} { + $result == "crumb tray: 0% full" +} + +test {Toast a few slices of bread a few different times} { + original clean + original toast 2 + original toast 1 +} { + $result == "crumb tray: 38% full" +} + +test {Toast too many slices of bread and cause a fire} { + puts stdout ">>> should say \"== FIRE! FIRE! ==\"" + original clean + original toast 2 + original toast 2 + original toast 2 + original toast 2 +} { + $result == "crumb tray: 100% full" +} + +test {Destroy the toaster} { + original clean + original toast 2 + original toast 1 + puts stdout ">>> should say \"15 crumbs ... what a mess!\"" + original delete +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# SMART TOASTERS +# ---------------------------------------------------------------------- +test {Create a toaster and plug it in} { + global Owner + SmartToaster deluxe -heat 4 -outlet [Outlet #auto -owner $Owner] +} { + $result == "deluxe" +} + +test {Toast a few slices of bread} { + deluxe toast 2 +} { + $result == "crumb tray: 20% full" +} + +test {Toast a few slices of bread and look for auto-clean} { + deluxe clean + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 +} { + $result == "crumb tray: 20% full" +} + +# ---------------------------------------------------------------------- +# PRODUCT STATISTICS +# ---------------------------------------------------------------------- +test {Check statistics gathered by Hazard base class} { + set tmp [Toaster #auto] + set stats [Hazard :: report ::Toaster] + $tmp delete + set stats +} { + $result == "::Toaster: 2 produced, 1 active, 1 accidents" +} + +test {Check statistics gathered by Hazard base class} { + Hazard :: report ::SmartToaster +} { + $result == "::SmartToaster: 1 produced, 1 active, 0 accidents" +} + +test {Destroy all Toasters} { + foreach toaster [itcl_info objects -isa Toaster] { + $toaster clean + $toaster delete + } +} { + $result == "" +} + +test {SmartToasters should have been destroyed along with Toasters} { + itcl_info objects -class SmartToaster +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# OUTLETS +# ---------------------------------------------------------------------- +test {Bill all customers for outlet charges} { + Outlet :: bill + puts stdout ">>> should send two bills for outlets via e-mail" +} { + $result == "" +} + +test {Destroy all outlets} { + foreach outlet [itcl_info objects -class Outlet] { + $outlet delete + } +} { + $result == "" +}

old/toaster.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/basic.test =================================================================== --- old/basic.test (nonexistent) +++ old/basic.test (revision 1765) @@ -0,0 +1,408 @@ +# +# Basic tests for class definition and method/proc access +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: basic.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. + +# ---------------------------------------------------------------------- +# CLEAN THE SLATE +# ---------------------------------------------------------------------- +foreach obj [itcl_info objects -class Foo] { + $obj delete +} + +# ---------------------------------------------------------------------- +# CREATING OBJECTS +# ---------------------------------------------------------------------- +test {Create a simple object} { + Foo x +} { + $result == "x" +} + +test {Make sure that object names cannot be duplicated} { + catch "Foo x" errmsg +} { + $result == 1 +} + +test {Create another object} { + Foo xx +} { + $result == "xx" +} + +test {Create an object with an automatic name} { + Foo #auto +} { + [string match foo* $result] +} + +test {Get list of objects in a class} { + itcl_info objects -class Foo +} { + [llength $result] == 3 +} + +# ---------------------------------------------------------------------- +# PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Info: all public variables} { + x info public +} { + [test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}] +} + +test {Info: public variable initial value} { + x info public blit -init +} { + $result == "" +} + +test {Info: public variable initial value (undefined)} { + x info public blit -value +} { + $result == "" +} + +test {Info: public variable initial value} { + x info public blat -init +} { + $result == 0 +} + +test {Info: public variable current value} { + x info public blot -value +} { + $result == 1 +} + +test {Info: public variable config statement} { + x info public blit -config +} { + $result == "" +} + +test {Info: public variable config statement} { + x info public blot -config +} { + $result == {global WATCH; set WATCH "blot=$blot"} +} + +# ---------------------------------------------------------------------- +# CONFIG-ING PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Setting public variables via "config"} { + x config -blit 27 -blat xyz +} { + $result == "Foo::blit Foo::blat" +} + +test {Info: public variable init/current value} { + x info public blit -init -value +} { + $result == {{} 27} +} + +test {Info: public variable init/current value} { + x info public blat -init -value +} { + $result == {0 xyz} +} + +test {"config" is ordinary arg if it is not last arg} { + x configx -blit pdq +} { + $result == {-blit|pdq} +} + +test {Public variables with "config" code} { + set WATCH "" + concat [x config -blot abc] / $WATCH +} { + $result == "Foo::blot / blot=abc" +} + +test {Make sure object data is local to objects} { + x config -blit abc + xx config -blit xyz + concat [x info public blit -value] / [xx info public blit -value] +} { + $result == "abc / xyz" +} + +# ---------------------------------------------------------------------- +# PROTECTED VARIABLES +# ---------------------------------------------------------------------- +test {Info: all protected variables} { + x info protected +} { + [test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}] +} + +test {Info: protected "this" variable} { + x info protected this -value +} { + $result == "::x" +} + +test {Info: protected "this" variable} { + xx info protected this -value +} { + $result == "::xx" +} + +test {Info: protected variable initial value} { + x info protected _blit -init +} { + $result == "" +} + +test {Info: protected variable access/value} { + x do {set _blit rst} +} { + $result == "Foo says 'rst'" && + [x info protected _blit -value] == "rst" +} + +# ---------------------------------------------------------------------- +# COMMON VARIABLES +# ---------------------------------------------------------------------- +test {Info: all protected variables} { + x info common +} { + [test_cmp_lists $result {Foo::foos Foo::nfoo}] +} + +test {Info: common variable initial value} { + x info common foos -init +} { + $result == "" +} + +test {Info: common variable initial value} { + x info common nfoo -init +} { + $result == 0 +} + +test {Info: common variable access/value} { + x do {set nfoo 999} + x info common nfoo -value +} { + $result == 999 +} + +test {Make sure common data is really common} { + x do {set nfoo 0} + x info common nfoo -value +} { + $result == [xx info common nfoo -value] +} + +test {Access common data in proc} { + x do {set nfoo 10} + Foo :: nfoos +} { + $result == 10 +} + +test {Common variables can be initialized within class definition} { + x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}} +} { + $result == "Foo says 'foos-is-now-an-array'" +} + +test {Arrays as common data} { + Foo :: foos +} { + [test_cmp_lists $result [itcl_info objects -class Foo]] +} + +# ---------------------------------------------------------------------- +# METHODS +# ---------------------------------------------------------------------- +test {Info: all methods} { + x info method +} { + [test_cmp_lists $result { + Foo::constructor Foo::destructor + Foo::nothing Foo::do Foo::xecho + Foo::config Foo::xconfig Foo::configx + Foo::testMethodArgs + Foo::configure Foo::delete Foo::cget Foo::isa + }] +} + +test {Info: method args} { + x info method nothing -args +} { + $result == "" +} + +test {Info: method args} { + x info method xconfig -args +} { + $result == "x config" +} + +test {Info: method body} { + x info method nothing -body +} { + $result == "" +} + +test {Info: method body} { + x info method xconfig -body +} { + $result == { + return "$x|$config" + } +} + +# ---------------------------------------------------------------------- +# PROCS +# ---------------------------------------------------------------------- +test {Info: all procs} { + x info proc +} { + [test_cmp_lists $result { + Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs + }] +} + +test {Info: proc args} { + x info proc nfoos -args +} { + $result == "" +} + +test {Info: proc args} { + x info proc foos -args +} { + $result == "{pattern *}" +} + +test {Info: proc body} { + x info proc nfoos -body +} { + $result == { + return $nfoo + } +} + +test {Info: proc body} { + x info body nfoos +} { + $result == { + return $nfoo + } +} + +# ---------------------------------------------------------------------- +# ARGUMENT LISTS +# ---------------------------------------------------------------------- +test {Default arguments can get assigned a proper value} { + Foo :: foos x* +} { + [test_cmp_lists $result {x xx}] +} + +test {Default value for "config" argument} { + x config +} { + $result == "Foo::blit Foo::blat" && + [x info public blit -value] == "auto" && + [x info public blat -value] == "matic" +} + +test {"args" formal argument absorbs extra arguments} { + Foo :: echo abc 1 2 3 +} { + $result == "abc | 3: 1 2 3" +} + +test {"args" formal argument absorbs extra arguments} { + Foo :: echo def +} { + $result == "def | 0: " +} + +test {"args" formal argument absorbs extra arguments} { + x xecho abc 1 2 3 +} { + $result == "abc | 3: 1 2 3" +} + +test {"args" formal argument absorbs extra arguments} { + x xecho def +} { + $result == "def | 0: " +} + +test {Extra args cause an error} { + catch "x configx arg arg error" +} { + $result != 0 +} + +test {Extra args cause an error} { + catch "x nothing error" +} { + $result != 0 +} + +test {Formal arguments don't clobber public/protected variables} { + x do { + set blit okay + set _blit no-problem + } + x testMethodArgs yuck puke etc. +} { + $result == "yuck, puke, and 1 other args" && + [x info public blit -value] == "okay" && + [x info protected _blit -value] == "no-problem" +} + +test {Formal arguments don't clobber common variables} { + Foo :: testProcArgs yuck etc. +} { + $result == "yuck, and 1 other args" && + [x info common nfoo -value] != "yuck" +} + +# ---------------------------------------------------------------------- +# DELETING OBJECTS +# ---------------------------------------------------------------------- +test {Delete an object} { + x delete +} { + $result == "" +} + +test {Delete an object} { + xx delete +} { + $result == "" +} + +test {Destructor is properly invoked} { + Foo :: foos +} { + [test_cmp_lists $result [itcl_info objects -class Foo]] +} + +test {Object names are removed as commands} { + expr {[info commands x] == "" && [info commands xx] == ""} +} { + $result == 1 +}

old/basic.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/AAA.test =================================================================== --- old/AAA.test (nonexistent) +++ old/AAA.test (revision 1765) @@ -0,0 +1,82 @@ +# +# AAA - first test executed in test suite +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: AAA.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. + +# ---------------------------------------------------------------------- +# SHOULD HAVE A CLEAN SLATE +# ---------------------------------------------------------------------- +test {No object info (no classes)} { + itcl_info classes +} { + $result == "" +} + +test {No object info (no objects)} { + itcl_info objects +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# TEST CLASS AUTO-LOADING +# ---------------------------------------------------------------------- +test {Force auto-loading through inheritance} { + FooBar x +} { + $result == "x" +} + +test {Info: all classes} { + itcl_info classes +} { + [test_cmp_lists $result {Foo Bar FooBar}] +} + +test {Info: all classes matching a pattern} { + itcl_info classes *oo* +} { + [test_cmp_lists $result {Foo FooBar}] +} + +# ---------------------------------------------------------------------- +# OBJECT AUTO-NUMBERING +# ---------------------------------------------------------------------- +test {Create object with auto-naming} { + FooBar #auto -blit x +} { + $result == "fooBar0" && [fooBar0 info public blit -value] == "x" +} + +test {Create object with auto-naming} { + FooBar #auto -blit y +} { + $result == "fooBar1" && [fooBar1 info public blit -value] == "y" +} + +test {Auto-naming should avoid names already in use} { + FooBar fooBar2 + FooBar fooBar3 + FooBar fooBar4 + FooBar #auto +} { + $result == "fooBar5" +} + +test {Destroy all outstanding objects} { + foreach obj [itcl_info objects] { + $obj delete + } +} { + $result == "" +}

old/AAA.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/Foo.tcl =================================================================== --- old/Foo.tcl (nonexistent) +++ old/Foo.tcl (revision 1765) @@ -0,0 +1,99 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: Foo.tcl,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. + +itcl_class Foo { + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + set foos([namespace tail $this]) $this + incr nfoo + } + destructor { + global WATCH + lappend WATCH [namespace current] + unset foos([namespace tail $this]) + } + + method nothing {} {} + + method do {cmds} { + return "Foo says '[eval $cmds]'" + } + + # + # Test formal arguments for methods/procs + # (formal args should not clobber data members) + # + method testMethodArgs {blit _blit args} { + return "$blit, $_blit, and [llength $args] other args" + } + proc testProcArgs {nfoo args} { + return "$nfoo, and [llength $args] other args" + } + + # + # Test methods using the "config" argument + # + method config {{config "-blit auto -blat matic"}} { + return $config + } + method xconfig {x config} { + return "$x|$config" + } + method configx {config x} { + return "$config|$x" + } + method xecho {x args} { + return "$x | [llength $args]: $args" + } + + # + # Test procs and access to common vars + # + proc echo {x args} { + return "$x | [llength $args]: $args" + } + proc foos {{pattern *}} { + set retn {} + foreach i [array names foos] { + if {$i != "_ignore_" && [string match $pattern $i]} { + lappend retn $i + } + } + return $retn + } + proc nfoos {} { + return $nfoo + } + + # + # Test public/protected/common variable definitions + # + public blit + public blat 0 + public blot 1 {global WATCH; set WATCH "blot=$blot"} + + protected _blit + protected _blat 0 + + common foos + set foos(_ignore_) "foos-is-now-an-array" + + common nfoo 0 +}

old/Foo.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/Toaster.tcl =================================================================== --- old/toasters/Toaster.tcl (nonexistent) +++ old/toasters/Toaster.tcl (revision 1765) @@ -0,0 +1,75 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Class definition for handling toasters via [incr Tcl]. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: Toaster.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Toaster { + inherit Appliance Hazard + + constructor {config} {} + destructor { + if {$crumbs > 0} { + puts stdout "$crumbs crumbs ... what a mess!" + } + } + method config {config} {} + + method toast {nslices} { + power [expr 0.03*$heat] + if {$nslices < 1 || $nslices > 2} { + error "bad number of slices: should be 1 or 2" + } + set crumbs [expr $crumbs+$heat*$nslices] + if {$crumbs >= $maxcrumbs} { + accident "== FIRE! FIRE! ==" + set crumbs $maxcrumbs + } + return [check] + } + + method clean {} { + power 0.5 + set crumbs 0 + return [check] + } + + method check {} { + set level [expr $crumbs*100.0/$maxcrumbs] + return [format "crumb tray: %.0f%% full" $level] + } + + proc resize {newsize} { + set maxcrumbs $newsize + } + + public heat 3 { + if {$heat < 1 || $heat > 5} { + error "invalid setting $heat: should be 1-5" + } + } + protected crumbs 0 + common maxcrumbs 40 +}

old/toasters/Toaster.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/SmartToaster.tcl =================================================================== --- old/toasters/SmartToaster.tcl (nonexistent) +++ old/toasters/SmartToaster.tcl (revision 1765) @@ -0,0 +1,40 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Class definition for handling "smart" toasters via +# [incr Tcl]. A "smart" toaster is a toaster that +# automatically cleans itself when the crumb tray is full. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: SmartToaster.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class SmartToaster { + inherit Toaster + + method toast {nslices} { + if {$crumbs >= [expr $maxcrumbs-10]} { + clean + } + return [Toaster::toast $nslices] + } +}

old/toasters/SmartToaster.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/Hazard.tcl =================================================================== --- old/toasters/Hazard.tcl (nonexistent) +++ old/toasters/Hazard.tcl (revision 1765) @@ -0,0 +1,78 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Tracking for hazardous products manufactured by the +# "toaster" company. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: Hazard.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class HazardRec { + constructor {cname} { + set class $cname + } + method change {var inc} { + if {![info exists $var]} { + error "bad field \"$var\"" + } + incr $var $inc + } + method report {} { + return "$class: $total produced, $actives active, $accidents accidents" + } + protected class {} + protected total 0 + protected actives 0 + protected accidents 0 +} + +itcl_class Hazard { + + constructor {} { + set class [virtual info class] + if {![info exists recs($class)]} { + set recs($class) [HazardRec #auto $class] + } + $recs($class) change total +1 + $recs($class) change actives +1 + } + destructor { + set class [virtual info class] + $recs($class) change actives -1 + } + + method accident {mesg} { + set class [virtual info class] + $recs($class) change accidents +1 + puts stderr $mesg + } + + proc report {class} { + if {[info exists recs($class)]} { + return [$recs($class) report] + } else { + error "no information for class \"$class\"" + } + } + common recs +}

old/toasters/Hazard.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/tclIndex =================================================================== --- old/toasters/tclIndex (nonexistent) +++ old/toasters/tclIndex (revision 1765) @@ -0,0 +1,18 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(Appliance) "source $dir/Appliance.tcl" +set auto_index(HazardRec) "source $dir/Hazard.tcl" +set auto_index(Hazard) "source $dir/Hazard.tcl" +set auto_index(Outlet) "source $dir/Outlet.tcl" +set auto_index(SmartToaster) "source $dir/SmartToaster.tcl" +set auto_index(Toaster) "source $dir/Toaster.tcl" +set auto_index(make_toaster) "source $dir/usualway.tcl" +set auto_index(toast_bread) "source $dir/usualway.tcl" +set auto_index(clean_toaster) "source $dir/usualway.tcl" +set auto_index(destroy_toaster) "source $dir/usualway.tcl"

old/toasters/tclIndex Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/usualway.tcl =================================================================== --- old/toasters/usualway.tcl (nonexistent) +++ old/toasters/usualway.tcl (revision 1765) @@ -0,0 +1,122 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Procedures for managing toasters in the usual +# procedure-oriented Tcl programming style. These +# routines illustrate data sharing through global +# variables and naming conventions to logically group +# related procedures. The same programming task can +# be accomplished much more cleanly with [incr Tcl]. +# Inheritance also allows new behavior to be "mixed-in" +# more cleanly (see Appliance and Product base classes). +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: usualway.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +# ---------------------------------------------------------------------- +# COMMAND: make_toaster +# +# INPUTS +# = name of new toaster +# = heat setting (1-5) +# +# RETURNS +# name of new toaster +# +# SIDE-EFFECTS +# Creates a record of a new toaster with the given heat setting +# and an empty crumb tray. +# ---------------------------------------------------------------------- +proc make_toaster {name heat} { + global allToasters + + if {$heat < 1 || $heat > 5} { + error "invalid heat setting: should be 1-5" + } + set allToasters($name-heat) $heat + set allToasters($name-crumbs) 0 +} + +# ---------------------------------------------------------------------- +# COMMAND: toast_bread +# +# INPUTS +# = name of toaster used to toast bread +# = number of bread slices (1 or 2) +# +# RETURNS +# current crumb count +# +# SIDE-EFFECTS +# Toasts bread and adds crumbs to crumb tray. +# ---------------------------------------------------------------------- +proc toast_bread {name slices} { + global allToasters + + if {[info exists allToasters($name-crumbs)]} { + set c $allToasters($name-crumbs) + set c [expr $c+$allToasters($name-heat)*$slices] + set allToasters($name-crumbs) $c + } else { + error "not a toaster: $name" + } +} + +# ---------------------------------------------------------------------- +# COMMAND: clean_toaster +# +# INPUTS +# = name of toaster to be cleaned +# +# RETURNS +# current crumb count +# +# SIDE-EFFECTS +# Cleans toaster by emptying crumb tray. +# ---------------------------------------------------------------------- +proc clean_toaster {name} { + global allToasters + set allToasters($name-crumbs) 0 +} + +# ---------------------------------------------------------------------- +# COMMAND: destroy_toaster +# +# INPUTS +# = name of toaster to be destroyed +# +# RETURNS +# nothing +# +# SIDE-EFFECTS +# Spills all crumbs in the toaster and then destroys it. +# ---------------------------------------------------------------------- +proc destroy_toaster {name} { + global allToasters + + if {[info exists allToasters($name-crumbs)]} { + puts stdout "$allToasters($name-crumbs) crumbs ... what a mess!" + unset allToasters($name-heat) + unset allToasters($name-crumbs) + } +}

old/toasters/usualway.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/Appliance.tcl =================================================================== --- old/toasters/Appliance.tcl (nonexistent) +++ old/toasters/Appliance.tcl (revision 1765) @@ -0,0 +1,43 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Base class for all electrical appliances that interact +# with Outlets. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: Appliance.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Appliance { + + method power {power} { + if {[itcl_info objects [info which $outlet]] == ""} { + set outlet {} + } + if {$outlet == ""} { + error "cannot use $this: not plugged in" + } + $outlet use $power + } + + public outlet {} +}

old/toasters/Appliance.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/toasters/Outlet.tcl =================================================================== --- old/toasters/Outlet.tcl (nonexistent) +++ old/toasters/Outlet.tcl (revision 1765) @@ -0,0 +1,81 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Electrical outlet supplying power for Appliances. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id: Outlet.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Outlet { + constructor {config} {} + method config {config} {} + + destructor { + if {$usage > 0} bill + } + + method use {power} { + set usage [expr $usage+$power] + } + + method sendBill {} { + if {[catch "open /tmp/bill w" fout] != 0} { + error "cannot create bill in /tmp" + } else { + set amount [format "$%.2f" [expr $usage*$rate]] + puts $fout "----------------------------------------" + puts $fout "/////////// MEGA-POWER, INC. ///////////" + puts $fout "----------------------------------------" + puts $fout " Customer: $owner" + puts $fout " Outlet: $this" + puts $fout " Usage: $usage kilowatt-hours" + puts $fout " " + puts $fout " Amount Due: $amount" + puts $fout "----------------------------------------" + close $fout + exec mail $owner < /tmp/bill + set usage 0 + } + } + + proc bill {{customer *}} { + foreach outlet [itcl_info objects -class Outlet] { + set owner [$outlet info public owner -value] + if {[string match $customer $owner]} { + $outlet sendBill + } + } + } + + proc rate {{newval ""}} { + if {$newval == ""} { + return $rate + } + set rate $newval + } + + public owner {} + protected usage 0 + + common rate 0.05 +}

old/toasters/Outlet.tcl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/all =================================================================== --- old/all (nonexistent) +++ old/all (revision 1765) @@ -0,0 +1,32 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: all,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. + +variable WATCH + +global TEST_ABS_TOL TEST_REL_TOL +set TEST_ABS_TOL 1.0e-6 +set TEST_REL_TOL 1.0e-5 + +if {![file readable "testlib.tcl"]} { + error "ERROR: execute test suite in \"tests\" directory" +} + +lappend auto_path . + +foreach i [lsort [glob ./*.test]] { + source $i +} +puts stdout "== ALL TESTS SUCCESSFUL ==" +exit

old/all Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/tclIndex =================================================================== --- old/tclIndex (nonexistent) +++ old/tclIndex (revision 1765) @@ -0,0 +1,24 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(Bar) "source $dir/Bar.tcl" +set auto_index(Foo) "source $dir/Foo.tcl" +set auto_index(BarFoo) "source $dir/BarFoo.tcl" +set auto_index(FooBar) "source $dir/FooBar.tcl" +set auto_index(Geek) "source $dir/Geek.tcl" +set auto_index(Mongrel) "source $dir/Mongrel.tcl" +set auto_index(VirtualErr) "source $dir/VirtualErr.tcl" +set auto_index(test) "source $dir/testlib.tcl" +set auto_index(test_cmp_nums) "source $dir/testlib.tcl" +set auto_index(test_cmp_vectors) "source $dir/testlib.tcl" +set auto_index(test_cmp_lists) "source $dir/testlib.tcl" +set auto_index(upvarTest_show_var) "source $dir/upvar.test" +set auto_index(upvarTest_upvar_in_procs) "source $dir/upvar.test" +set auto_index(uplevelTest_show_var) "source $dir/uplevel.test" +set auto_index(uplevelTest_do) "source $dir/uplevel.test" +set auto_index(Baz) "source $dir/Baz.tcl"

old/tclIndex Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: old/upvar.test =================================================================== --- old/upvar.test (nonexistent) +++ old/upvar.test (revision 1765) @@ -0,0 +1,110 @@ +# +# Tests for "upvar" across interpreter boundaries +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: upvar.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. + +# ---------------------------------------------------------------------- +# DEFINE SOME USEFUL ROUTINES +# ---------------------------------------------------------------------- +proc upvarTest_show_var {var val} { + return "$var>>$val" +} + +proc upvarTest_upvar_in_procs {} { + set upvarTest_var_local "value in main interp" + foo do { + upvar upvarTest_var_local var + set var + } +} + +# ---------------------------------------------------------------------- +# CREATE SOME OBJECTS +# ---------------------------------------------------------------------- +Foo foo +Baz baz + +# ---------------------------------------------------------------------- +# UPVAR TESTS +# ---------------------------------------------------------------------- +test {"::" sends command to global interp but preserves +local variables. This ensures that when control +shifts to the global scope for Extended Tcl commands, +Expect commands, etc., local variables will be +recognized.} { + foo do { + set localvar "special" + ::eval {upvarTest_show_var localvar $localvar} + } +} { + $result == "Foo says 'localvar>>special'" +} + + +test {"upvar" can cross interp boundaries to access local variables} { + upvarTest_upvar_in_procs +} { + $result == "Foo says 'value in main interp'" +} + +test {"upvar" can cross interp boundaries to access global variables} { + set upvarTest_var_global "value in main interp" + foo do { + upvar upvarTest_var_global var + set var + } +} { + $result == "Foo says 'value in main interp'" +} + +test {"upvar" can handle multiple call frames on the stack} { + set upvarTest_var_global "new value" + foo do { + foo do { + upvar #0 upvarTest_var_global var + set var + } + } +} { + $result == "Foo says 'Foo says 'new value''" +} + +test {"upvar" can cross class interp boundaries} { + baz do { + set localvar "value in Baz" + foo do { + upvar localvar var + set var + } + } +} { + $result == "Baz says 'Foo says 'value in Baz''" +} + +test {"upvar" can cross class interp boundaries back to main interp} { + set upvarTest_var_global "global value" + baz do { + foo do { + upvar 2 upvarTest_var_global var + set var + } + } +} { + $result == "Baz says 'Foo says 'global value''" +} + +# ---------------------------------------------------------------------- +# CLEAN UP +# ---------------------------------------------------------------------- +foo delete +baz delete

old/upvar.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property

Browse

Tools

Subversion Repositories or1k

Compare Revisions

Rev 578 → Rev 1765