URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
Compare Revisions
- This comparison shows the changes necessary to convert path
/or1k/trunk/insight/itcl/itcl/tests
- from Rev 1765 to Rev 578
- ↔ Reverse comparison
Rev 1765 → Rev 578
/interp.test
File deleted
interp.test
Property changes :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: inherit.test
===================================================================
--- inherit.test (revision 1765)
+++ inherit.test (nonexistent)
@@ -1,576 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: delete.test
===================================================================
--- delete.test (revision 1765)
+++ delete.test (nonexistent)
@@ -1,204 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: methods.test
===================================================================
--- methods.test (revision 1765)
+++ methods.test (nonexistent)
@@ -1,128 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: defs
===================================================================
--- defs (revision 1765)
+++ defs (nonexistent)
@@ -1,343 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: scope.test
===================================================================
--- scope.test (revision 1765)
+++ scope.test (nonexistent)
@@ -1,207 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: mkindex.itcl
===================================================================
--- mkindex.itcl (revision 1765)
+++ mkindex.itcl (nonexistent)
@@ -1,88 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: basic.test
===================================================================
--- basic.test (revision 1765)
+++ basic.test (nonexistent)
@@ -1,319 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: chain.test
===================================================================
--- chain.test (revision 1765)
+++ chain.test (nonexistent)
@@ -1,148 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: protection.test
===================================================================
--- protection.test (revision 1765)
+++ protection.test (nonexistent)
@@ -1,370 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: local.test
===================================================================
--- local.test (revision 1765)
+++ local.test (nonexistent)
@@ -1,66 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: ensemble.test
===================================================================
--- ensemble.test (revision 1765)
+++ ensemble.test (nonexistent)
@@ -1,185 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: all
===================================================================
--- all (revision 1765)
+++ all (nonexistent)
@@ -1,16 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: info.test
===================================================================
--- info.test (revision 1765)
+++ info.test (nonexistent)
@@ -1,384 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: tclIndex
===================================================================
--- tclIndex (revision 1765)
+++ tclIndex (nonexistent)
@@ -1,24 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: namespace.test
===================================================================
--- namespace.test (revision 1765)
+++ namespace.test (nonexistent)
@@ -1,74 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: body.test
===================================================================
--- body.test (revision 1765)
+++ body.test (nonexistent)
@@ -1,218 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: mkindex.test
===================================================================
--- mkindex.test (revision 1765)
+++ mkindex.test (nonexistent)
@@ -1,44 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/inherit.test
===================================================================
--- old/inherit.test (revision 1765)
+++ old/inherit.test (nonexistent)
@@ -1,272 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/VirtualErr.tcl
===================================================================
--- old/VirtualErr.tcl (revision 1765)
+++ old/VirtualErr.tcl (nonexistent)
@@ -1,23 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/Mongrel.tcl
===================================================================
--- old/Mongrel.tcl (revision 1765)
+++ old/Mongrel.tcl (nonexistent)
@@ -1,34 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/Bar.tcl
===================================================================
--- old/Bar.tcl (revision 1765)
+++ old/Bar.tcl (nonexistent)
@@ -1,39 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/testlib.tcl
===================================================================
--- old/testlib.tcl (revision 1765)
+++ old/testlib.tcl (nonexistent)
@@ -1,131 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/FooBar.tcl
===================================================================
--- old/FooBar.tcl (revision 1765)
+++ old/FooBar.tcl (nonexistent)
@@ -1,31 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/BarFoo.tcl
===================================================================
--- old/BarFoo.tcl (revision 1765)
+++ old/BarFoo.tcl (nonexistent)
@@ -1,31 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/uplevel.test
===================================================================
--- old/uplevel.test (revision 1765)
+++ old/uplevel.test (nonexistent)
@@ -1,155 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/Geek.tcl
===================================================================
--- old/Geek.tcl (revision 1765)
+++ old/Geek.tcl (nonexistent)
@@ -1,44 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/Baz.tcl
===================================================================
--- old/Baz.tcl (revision 1765)
+++ old/Baz.tcl (nonexistent)
@@ -1,27 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toaster.test
===================================================================
--- old/toaster.test (revision 1765)
+++ old/toaster.test (nonexistent)
@@ -1,165 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/basic.test
===================================================================
--- old/basic.test (revision 1765)
+++ old/basic.test (nonexistent)
@@ -1,408 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/AAA.test
===================================================================
--- old/AAA.test (revision 1765)
+++ old/AAA.test (nonexistent)
@@ -1,82 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/Foo.tcl
===================================================================
--- old/Foo.tcl (revision 1765)
+++ old/Foo.tcl (nonexistent)
@@ -1,99 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/Toaster.tcl
===================================================================
--- old/toasters/Toaster.tcl (revision 1765)
+++ old/toasters/Toaster.tcl (nonexistent)
@@ -1,75 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/SmartToaster.tcl
===================================================================
--- old/toasters/SmartToaster.tcl (revision 1765)
+++ old/toasters/SmartToaster.tcl (nonexistent)
@@ -1,40 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/Hazard.tcl
===================================================================
--- old/toasters/Hazard.tcl (revision 1765)
+++ old/toasters/Hazard.tcl (nonexistent)
@@ -1,78 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/tclIndex
===================================================================
--- old/toasters/tclIndex (revision 1765)
+++ old/toasters/tclIndex (nonexistent)
@@ -1,18 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/usualway.tcl
===================================================================
--- old/toasters/usualway.tcl (revision 1765)
+++ old/toasters/usualway.tcl (nonexistent)
@@ -1,122 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/Appliance.tcl
===================================================================
--- old/toasters/Appliance.tcl (revision 1765)
+++ old/toasters/Appliance.tcl (nonexistent)
@@ -1,43 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/toasters/Outlet.tcl
===================================================================
--- old/toasters/Outlet.tcl (revision 1765)
+++ old/toasters/Outlet.tcl (nonexistent)
@@ -1,81 +0,0 @@
-# ----------------------------------------------------------------------
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/all
===================================================================
--- old/all (revision 1765)
+++ old/all (nonexistent)
@@ -1,32 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/tclIndex
===================================================================
--- old/tclIndex (revision 1765)
+++ old/tclIndex (nonexistent)
@@ -1,24 +0,0 @@
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Index: old/upvar.test
===================================================================
--- old/upvar.test (revision 1765)
+++ old/upvar.test (nonexistent)
@@ -1,110 +0,0 @@
-#
-# 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 :
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property