Import Tcl 8.6.12

pkgs/itcl4.2.2/tests/all.tcl

@@ -0,0 +1,31 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tcl
+# tests.  Execute it by invoking "source all.test" when running tcltest
+# in this directory.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions
+# All rights reserved.
+
+if {"-testdir" ni $argv} {
+    lappend argv -testdir [file dir [info script]]
+}
+
+if {[namespace which -command memory] ne "" && "-loadfile" ni $argv} {
+    puts "Tests running in sub-interpreters of leaktest circuit"
+    # -loadfile overwrites -load, so save it for helper in ::env(TESTFLAGS):
+    if {![info exists ::env(TESTFLAGS)] && [llength $argv]} {
+        set ::env(TESTFLAGS) $argv
+    }
+    lappend argv -loadfile [file join [file dirname [info script]] helpers.tcl]
+}
+
+package prefer latest
+
+package require Tcl 8.6-
+package require tcltest 2.2
+
+tcltest::configure {*}$argv
+tcltest::runAllTests
+
+return

pkgs/itcl4.2.2/tests/basic.test

@@ -0,0 +1,611 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+test basic-1.0 {empty string as class name should fail but not crash
+} -body {
+    list [catch {itcl::class "" {}} err] $err
+} -result {1 {invalid class name ""}}
+
+# ----------------------------------------------------------------------
+#  Simple class definition
+# ----------------------------------------------------------------------
+
+variable setup {
+    itcl::class Counter {
+        constructor {args} {
+            incr num
+            eval configure $args
+        }
+        destructor {
+            if {![info exists num]} {
+                lappend ::tcltest::itcl_basic_errors "unexpected: common deleted before destructor got called"
+            }
+            incr num -1
+        }
+
+        method ++ {} {
+            return [incr val $by]
+        }
+        proc num {} {
+            return $num
+        }
+        public variable by 1
+        protected variable val 0
+        private common num 0
+    }
+}
+
+variable cleanup {
+    itcl::delete class Counter
+}
+
+variable setup2 $setup
+append setup2 {
+    set x [Counter x]
+}
+
+variable cleanup2 $cleanup
+append cleanup2 {
+    unset x
+}
+
+variable setup3 $setup
+append setup3 {
+    Counter -foo
+}
+
+variable setup4 $setup
+append setup4 {
+    Counter c
+}
+
+proc check_itcl_basic_errors {} {
+    if {[info exists ::tcltest::itcl_basic_errors] && [llength $::tcltest::itcl_basic_errors]} {
+        error "following errors occurs during tests:\n  [join $::tcltest::itcl_basic_errors "\n  "]"
+    }
+}
+
+test basic-1.1 {define a simple class
+} -setup $setup -body {
+} -cleanup $cleanup -result {}
+
+test basic-1.2 {class is now defined
+} -setup $setup -body {
+    itcl::find classes Counter
+} -cleanup $cleanup -result Counter
+
+test basic-1.3 {access command exists with class name
+} -setup $setup -body {
+    namespace which -command Counter
+} -cleanup $cleanup -result ::Counter
+
+test basic-1.4 {create a simple object
+} -setup $setup2 -body {
+    return $x
+} -cleanup $cleanup2 -result x
+
+test basic-1.5a {object names cannot be duplicated
+} -setup $setup2 -body {
+    list [catch "Counter x" msg] $msg
+} -cleanup $cleanup2 -result {1 {command "x" already exists in namespace "::"}}
+
+test basic-1.5b {built-in commands cannot be clobbered
+} -setup $setup -body {
+    list [catch "Counter info" msg] $msg
+} -cleanup $cleanup -result {1 {command "info" already exists in namespace "::"}}
+
+test basic-1.6 {objects have an access command
+} -setup $setup2 -body {
+    namespace which -command x
+} -cleanup $cleanup2 -result ::x
+
+test basic-1.7a {objects are added to the global list
+} -setup $setup2 -body {
+    itcl::find objects x
+} -cleanup $cleanup2 -result x
+
+test basic-1.7b {objects are added to the global list
+} -setup $setup2 -body {
+    itcl::find objects -class Counter x
+} -cleanup $cleanup2 -result x
+
+test basic-1.8 {objects can be deleted
+} -setup $setup2 -body {
+    list [itcl::delete object x] [namespace which -command x]
+} -cleanup $cleanup2 -result {{} {}}
+
+test basic-1.9 {objects can be recreated with the same name
+} -setup $setup2 -body {
+    itcl::delete object x
+    Counter x
+} -cleanup $cleanup2 -result x
+
+test basic-1.10 {objects can be destroyed by deleting their access command
+} -setup $setup2 -body {
+    rename ::x {}
+    itcl::find objects x
+} -cleanup $cleanup2 -result {}
+
+test basic-1.11 {find command supports object names starting with -
+} -setup $setup3 -body {
+    itcl::find objects -class Counter -foo
+} -cleanup $cleanup -result -foo
+
+test basic-1.12 {is command with class argument
+} -setup $setup -body {
+    itcl::is class Counter
+} -cleanup $cleanup -result 1
+
+test basic-1.13 {is command with class argument (global namespace)
+} -setup $setup -body {
+    itcl::is class ::Counter
+} -cleanup $cleanup -result 1
+
+test basic-1.14 {is command with class argument (wrapped in code command)
+} -setup $setup -body {
+    itcl::is class [itcl::code Counter]
+} -cleanup $cleanup -result 1
+
+test basic-1.15 {is command with class argument (class does not exist)
+} -body {
+    itcl::is class Count
+} -result 0
+
+test basic-1.16 {is command with object argument
+} -setup $setup3 -body {
+    itcl::is object -foo
+} -cleanup $cleanup -result 1
+
+test basic-1.17 {is command with object argument (object does not exist)
+} -body {
+    itcl::is object xxx
+} -result 0
+
+test basic-1.18 {is command with object argument (with code command)
+} -setup $setup3 -body {
+    itcl::is object [itcl::code -- -foo]
+} -cleanup $cleanup -result 1
+
+test basic-1.19 {classes can be unicode
+} -body {
+    itcl::class \u6210bcd { method foo args { return "bar" } }
+    \u6210bcd #auto
+} -result "\u6210bcd0"
+
+test basic-1.20 {
+    classes can be unicode
+} -body {
+    \u6210bcd0 foo
+} -cleanup {
+    ::itcl::delete class \u6210bcd
+} -result {bar}
+
+test basic-1.21 {error on empty class name
+} -body {
+    itcl::class {} {}
+} -returnCodes error -result {invalid class name ""}
+
+test basic-1.22 {error on empty object name
+} -setup {
+    itcl::class ::A {}
+} -body {
+    ::A {}
+} -cleanup {
+    ::itcl::delete class ::A
+} -returnCodes error -result {object name must not be empty}
+
+# ----------------------------------------------------------------------
+#  #auto names
+# ----------------------------------------------------------------------
+test basic-2.1 {create an object with an automatic name
+} -setup $setup -body {
+    Counter #auto
+} -cleanup $cleanup -result {counter0}
+
+test basic-2.2 {bury "#auto" within object name
+} -setup $setup -body {
+    Counter x#autoy
+} -cleanup $cleanup -result {xcounter0y}
+
+test basic-2.3 {bury "#auto" within object name
+} -setup $setup -body {
+    Counter a#aut#autob
+} -cleanup $cleanup -result {a#autcounter0b}
+
+test basic-2.4 {"#auto" is smart enough to skip names that are taken
+} -setup $setup -body {
+    Counter counter3
+    Counter #auto
+} -cleanup $cleanup -result {counter0}
+
+test basic-2.5 {"#auto" with :: at front of name
+} -body {
+    itcl::class AutoCheck {}
+    set result [AutoCheck ::#auto]
+    rename AutoCheck {}
+    set result
+} -result {::autoCheck0}
+
+test basic-2.6 {"#auto" with :: at front of name inside method
+} -body {
+    itcl::class AutoCheck {
+        proc new {} {
+            return [AutoCheck ::#auto]
+        }
+    }
+    set result [AutoCheck::new]
+    rename AutoCheck {}
+    set result
+} -result {::autoCheck0}
+
+test basic-2.7 {"#auto" with :: at front of name inside method inside namespace
+} -body {
+    namespace eval AutoCheckNs {}
+    itcl::class AutoCheckNs::AutoCheck {
+        proc new {} {
+            return [AutoCheckNs::AutoCheck ::#auto]
+        }
+    }
+    set result [AutoCheckNs::AutoCheck::new]
+    namespace delete AutoCheckNs
+    set result
+} -cleanup {
+    namespace delete ::itcl::internal::variables::AutoCheckNs
+} -result {::autoCheck0}
+
+test basic-3.1 {object access command works
+} -setup $setup4 -body {
+    list [c ++] [c ++] [c ++]
+} -cleanup $cleanup -result {1 2 3}
+
+test basic-3.2 {errors produce usage info
+} -setup $setup4 -body {
+    list [catch "c xyzzy" msg] $msg
+} -cleanup $cleanup -result {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
+} -setup $setup4 -body {
+    c configure
+} -cleanup $cleanup -result {{-by 1 1}}
+
+test basic-3.4 {built-in configure can query one public variable
+} -setup $setup4 -body {
+    c configure -by
+} -cleanup $cleanup -result {-by 1 1}
+
+test basic-3.5 {built-in configure can set public variable
+} -setup $setup4 -body {
+    list [c configure -by 2] [c cget -by]
+} -cleanup $cleanup -result {{} 2}
+
+test basic-3.6 {configure actually changes public variable
+} -setup $setup4 -body {
+    list [c ++] [c ++]
+} -cleanup $cleanup -result {1 2}
+
+test basic-3.7 {class procs can be accessed
+} -setup $setup -body {
+    Counter::num
+} -cleanup $cleanup -result 0
+
+test basic-3.8 {obsolete syntax is no longer allowed
+} -setup $setup -body {
+    list [catch "Counter :: num" msg] $msg
+} -cleanup $cleanup -result {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
+} -setup $setup -body {
+    list [itcl::delete class Counter] \
+         [itcl::find classes Counter] \
+         [namespace children :: Counter] \
+         [namespace which -command Counter]
+} -result {{} {} {} {}}
+
+test basic-4.2 {classes can be redefined
+} -body {
+    itcl::class Counter {
+        method ++ {} {
+            return [incr val $by]
+        }
+        public variable by 1
+        protected variable val 0
+    }
+} -result {}
+
+test basic-4.3 {the redefined class is actually different
+} -body {
+    list [catch "Counter::num" msg] $msg
+} -result {1 {invalid command name "Counter::num"}}
+
+test basic-4.4 {objects can be created from the new class
+} -body {
+    list [Counter #auto] [Counter #auto]
+} -result {counter0 counter1}
+
+test basic-4.5 {namespaces for #auto are prepended to the command name
+} -body {
+    namespace eval someNS1 {}
+    namespace eval someNS2 {}
+    list [Counter someNS1::#auto] [Counter someNS2::#auto]
+} -cleanup {
+    ::itcl::delete object someNS1::counter2 someNS2::counter3
+} -result "[list someNS1::counter2 someNS2::counter3]"
+
+test basic-4.6 {when a class is destroyed, its objects are deleted
+} -body {
+    list [lsort [itcl::find objects counter*]] \
+         [itcl::delete class Counter] \
+         [lsort [itcl::find objects counter*]]
+} -result {{counter0 counter1} {} {}}
+
+check_itcl_basic_errors
+
+test basic-4.7 {clean-up of internal facilities
+} -setup $setup4 -body {
+    # check callbacks are called if class gets removed using all possible ways:
+    # objects are properly destroyed,
+    # callback removing the namespace for the common private and protected variables
+    # (in ITCL_VARIABLES_NAMESPACE) is called, etc
+    set ::tcltest::itcl_basic_errors {}
+    set ivns ::itcl::internal::variables[namespace which Counter]
+    set result {}
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    eval $cleanup
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    eval $setup4
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    rename Counter {}
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    eval $setup4
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    namespace delete Counter
+    lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
+    lappend result {*}$::tcltest::itcl_basic_errors
+} -cleanup {
+    unset -nocomplain ivns ::tcltest::itcl_basic_errors
+} -result [lrepeat 3 1 1 0 0]
+
+# ----------------------------------------------------------------------
+#  Namespace variables
+# ----------------------------------------------------------------------
+test basic-5.1 {define a simple class with variables in the namespace
+} -body {
+    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"
+    }
+} -result {}
+
+test basic-5.2 {create an object for the tests
+} -body {
+    test_globals #auto
+} -result {test_globals0}
+
+test basic-5.3 {common variables live in the namespace
+} -body {
+    lsort [info vars ::test_globals::*]
+} -result {::test_globals::g1 ::test_globals::g2}
+
+test basic-5.4 {common variables can be referenced transparently
+} -body {
+    list [catch {test_globals0 do set g1} msg] $msg
+} -result {0 global1}
+
+test basic-5.5 {namespace variables require a declaration
+} -body {
+    list [catch {test_globals0 do set g2} msg] $msg
+} -result {1 {can't read "g2": no such variable}}
+
+test basic-5.6a {variable accesses variables within namespace
+} -body {
+    list [catch {test_globals::getval g1} msg] $msg
+} -result {0 global1}
+
+test basic-5.6b {variable accesses variables within namespace
+} -body {
+    list [catch {test_globals::getval g2} msg] $msg
+} -result {0 global2}
+
+test basic-5.7 {variable command will not find vars in other namespaces
+} -body {
+    set ::test_global_0 "g0"
+    list [catch {test_globals::getval test_global_0} msg] $msg \
+         [catch {test_globals::getval ::test_global_0} msg] $msg \
+} -result {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
+} -body {
+    test_globals::setval ::test_global_1 g1
+    namespace eval :: {lsort [info globals test_global_*]}
+} -result {test_global_0 test_global_1}
+
+test basic-5.9 {variable names can have ":" in them
+} -body {
+    test_globals::setval ::test:global:2 g2
+    namespace eval :: {info globals test:global:2}
+} -result {test:global:2}
+
+if {[namespace which [namespace current]::test_globals] ne {}} {
+    ::itcl::delete class test_globals
+}
+
+
+
+# ----------------------------------------------------------------------
+#  Array variables
+# ----------------------------------------------------------------------
+test basic-6.1 {set up a class definition with array variables
+} -body {
+    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
+} -result {test_arrays0}
+
+test basic-6.2 {test array access for instance variables
+} -body {
+    lsort [test_arrays0 do array get nums]
+} -result {1 2 3 one three two}
+
+test basic-6.3 {test array access for commons
+} -body {
+    lsort [test_arrays0 do array get colors]
+} -result [list #0000ff #00ff00 #ff0000 blue green red]
+
+test basic-6.4 {test array access for instance variables via "upvar"
+} -body {
+    test_arrays0 do test_arrays_get nums
+} -result {{one 1} {three 3} {two 2}}
+
+test basic-6.5 {test array access for commons via "upvar"
+} -body {
+    test_arrays0 do test_arrays_get colors
+} -result {{blue #0000ff} {green #00ff00} {red #ff0000}}
+
+test basic-6.6a {test array access for commons defined in constructor
+} -body {
+    lsort [test_arrays0 do array get undefined]
+} -result {A B a b}
+
+test basic-6.6b {test array access for commons defined in constructor
+} -body {
+    test_arrays0 do test_arrays_get undefined
+} -result {{a A} {b B}}
+
+test basic-6.6c {test array access for commons defined in constructor
+} -body {
+    list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]
+} -result {A B}
+
+test basic-6.7 {common variables can be unset
+} -body {
+    test_arrays0 do unset undefined
+    test_arrays0 do array names undefined
+} -result {}
+
+test basic-6.8 {common variables can be redefined
+} -body {
+    test_arrays0 do set undefined "scalar"
+} -result {scalar}
+
+proc testVarResolver {{access private} {init 0}} {
+  eval [string map [list \$access $access \$init $init] {
+    itcl::class A {
+	$access common cv "A::cv"
+	public proc cv {} {set cv}
+    }
+    itcl::class B {
+	inherit A
+	public common res {}
+	lappend res [info exists cv]
+	if {$init} {
+	    $access common cv ""
+	} else {
+	    $access common cv
+	}
+	lappend res [info exists cv]
+	lappend cv "B::cv-add"
+	public proc cv {} {set cv}
+    }
+    lappend B::res [A::cv] [B::cv]
+    set B::res
+  }]
+}
+test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
+    # private uninitialized var:
+    testVarResolver private 0
+} -result {0 0 A::cv B::cv-add} -cleanup {
+    itcl::delete class B A
+}
+test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
+    # public uninitialized var:
+    testVarResolver public 0
+} -result {1 0 A::cv B::cv-add} -cleanup {
+    itcl::delete class B A
+}
+test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
+    # private initialized var:
+    testVarResolver private 1
+} -result {0 1 A::cv B::cv-add} -cleanup {
+    itcl::delete class B A
+}
+test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
+    # public initialized var:
+    testVarResolver public 1
+} -result {1 1 A::cv B::cv-add} -cleanup {
+    itcl::delete class B A
+}
+
+if {[namespace which test_arrays] ne {}} {
+    ::itcl::delete class test_arrays
+}
+check_itcl_basic_errors
+rename check_itcl_basic_errors {}
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/body.test

@@ -0,0 +1,259 @@
+#
+# Tests for "body" and "configbody" commands
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Test "body" command
+# ----------------------------------------------------------------------
+test body-1.1 {define a class with missing bodies and arg lists} {
+    itcl::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 "itcl::body test_body::any" msg] $msg
+} {1 {wrong # args: should be "itcl::body class::func arglist body"}}
+
+test body-1.4 {make sure members are found correctly} {
+    list [catch "itcl::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} {
+    itcl::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} {
+    itcl::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} {
+    itcl::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 {itcl::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 {itcl::body test_body::zero {} {return "zero"}} msg] $msg
+} {0 {}}
+
+test body-1.7a {preserve argument list:  fixed arguments} {
+    list [catch {itcl::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 {itcl::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 {itcl::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 {itcl::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 {itcl::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 {itcl::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 {itcl::body test_body::defvals {a {b 0} {c 1}} {}} msg] $msg
+} {0 {}}
+
+test body-1.10a {preserve argument list:  variable arguments} {
+    list [catch {itcl::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 {itcl::body test_body::varargs {a} {}} msg] $msg
+} {0 {}}
+
+test body-1.10c {preserve argument list:  variable arguments} {
+    list [catch {itcl::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"] \
+         [itcl::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} {
+    itcl::class test_ibody {
+        inherit test_body
+        method zero {}
+    }
+    test_ibody #auto
+} {test_ibody0}
+
+test body-2.2 {redefine a method in a derived class} {
+    itcl::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 {itcl::body test_ibody::one {x} {return "new"}} msg] $msg
+} {1 {function "one" is not defined in class "::test_ibody"}}
+
+::itcl::delete class test_body
+
+# ----------------------------------------------------------------------
+#  Test "configbody" command
+# ----------------------------------------------------------------------
+test body-3.1 {define a class with public variables} {
+    itcl::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 "itcl::configbody test_cbody::option" msg] $msg
+} {1 {wrong # args: should be "itcl::configbody class::option body"}}
+
+test body-3.3 {make sure that members are found correctly} {
+    list [catch "itcl::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 "itcl::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 "itcl::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"] \
+         [itcl::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} {
+    itcl::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} {
+    itcl::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 {itcl::configbody test_icbody::nocode {return "new"}} msg] $msg
+} {1 {option "nocode" is not defined in class "::test_icbody"}}
+
+test body-5.1 {redefine constructors} -setup {
+    unset -nocomplain answer
+    itcl::class B {constructor {} {lappend ::answer B}}
+    itcl::class D {inherit B; constructor {} {lappend ::answer A}}
+} -body {
+    D d1
+    itcl::body D::constructor {} {lappend ::answer D}
+    D d2
+    set ::answer
+} -cleanup {
+    itcl::delete class B
+    unset -nocomplain answer
+} -result {B A B D}
+
+test body-6.1 {redefine class proc body} -setup {
+    unset -nocomplain ::answer
+    itcl::class C {
+	proc cheshire {} {
+	    lappend ::answer x
+	    itcl::body ::C::cheshire {} {}
+	}
+	constructor {args} {cheshire}
+    }
+} -body {
+    itcl::delete object [C #auto]
+    itcl::delete object [C #auto]
+    itcl::delete object [C #auto]
+    set ::answer
+} -cleanup {
+    itcl::delete class C
+    unset -nocomplain ::answer
+} -result x
+
+# ----------------------------------------------------------------------
+#  Clean up
+# ----------------------------------------------------------------------
+
+itcl::delete class test_cbody
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/chain.test

@@ -0,0 +1,166 @@
+#
+# Tests for chaining methods and procs
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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}}
+
+test chain-4.0 {[35a5baca67]} -setup {
+    unset -nocomplain ::answer
+    itcl::class B {method act args {lappend ::answer B}}
+    itcl::class D {inherit B; method act args {lappend ::answer D; chain}}
+} -body {
+    [D d] act Now!
+    set ::answer
+} -cleanup {
+    itcl::delete class B
+    unset -nocomplain ::answer
+} -result {D B}
+
+# ----------------------------------------------------------------------
+#  Clean up
+# ----------------------------------------------------------------------
+itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/delete.test

@@ -0,0 +1,214 @@
+#
+# Tests for deleting classes and objects
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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 [itcl::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 [itcl::delete class test_delete_base] \
+         [itcl::find classes test_delete_base] \
+         [namespace children :: test_delete_base] \
+         [namespace which -command test_delete_base] \
+         [itcl::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 [itcl::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 [itcl::delete class test_delete_base] \
+         [itcl::find classes test_delete*] \
+         [namespace children :: test_delete*] \
+         [namespace which -command test_delete_base] \
+         [namespace which -command test_delete] \
+         [itcl::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 [itcl::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] \
+         [itcl::find classes test_delete*] \
+         [namespace children :: test_delete*] \
+         [namespace which -command test_delete_base] \
+         [namespace which -command test_delete] \
+         [itcl::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 delete-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} {
+            itcl::delete object $this
+            eval $code
+        }
+    }
+} {}
+
+test delete-4.2 {an object can delete itself
+} -body {
+    set obj [test_delete #auto -x "data stays"]
+    list [$obj killme {return $x}] [itcl::find objects -isa test_delete]
+} -constraints {
+    only_working_in_itcl3.4
+} -result {{data stays} {}}
+
+test delete-4.3 {the "this" variable becomes null after delete} {
+    set obj [test_delete #auto]
+    list [$obj killme {return $this}] [itcl::find objects -isa test_delete]
+} {{} {}}
+
+test delete-4.4 {an object being destructed can't be deleted} {
+    set obj [test_delete #auto -deletecommand {itcl::delete object $this}]
+    list [catch {itcl::delete object $obj} msg] $msg
+} {1 {can't delete an object while it is being destructed}}
+
+if {[namespace which [namespace current]::test_delete] ne {}} {
+    namespace delete test_delete
+}
+
+# ----------------------------------------------------------------------
+#  Delete objects using path names and scoped values
+# ----------------------------------------------------------------------
+test delete-5.1 {define a simple class} {
+    itcl::class test_delete_name {
+        private variable x 0
+        method test {x} {
+            return $x
+        }
+    }
+} {}
+
+test delete-5.2 {delete using a qualified name} {
+    namespace eval test_delete2 {test_delete_name #auto}
+    set cmd {itcl::delete object test_delete2::test_delete_name0}
+    list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name]
+} {0 {} {}}
+
+test delete-5.3 {delete using a scoped value} {
+    set obj [namespace eval test_delete2 {itcl::code [test_delete_name #auto]}]
+    set cmd [list itcl::delete object $obj]
+    list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name]
+} {0 {} {}}
+
+test delete-5.4 {scoped command names are decoded properly} {
+    list [catch {itcl::delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
+         [catch {itcl::delete object {namespace inscope :: xxx yyy}} msg] $msg \
+         [catch {itcl::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
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/eclasscomponent.test

@@ -0,0 +1,319 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       eclasscomponent.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::extendedclass component command.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+#---------------------------------------------------------------------
+
+loadTestedCommands
+
+test component-1.1 {component defines variable} -body {
+    ::itcl::extendedclass dog {
+        protected component mycomp
+
+        public proc test {} {
+            return $mycomp
+        }
+    }
+
+    dog fido
+    fido test
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {}
+
+test component-1.2 {component -inherit} -body {
+    ::itcl::extendedclass dog {
+        component mycomp -inherit
+
+        constructor {} {
+            set mycomp string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {3}
+
+test component-1.3 {component -inherit can only have one of it} -body {
+    ::itcl::extendedclass dogbase {
+        component mycompbase -inherit
+    }
+
+    ::itcl::extendedclass dog {
+	inherit dogbase
+        component mycomp -inherit
+
+        constructor {} {
+            set mycomp string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete class dog
+    ::itcl::delete class dogbase
+} -returnCodes {
+    error
+} -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"}
+
+#-----------------------------------------------------------------------
+# Typemethod delegation
+
+test delegatemethod-1.1 {delegate method to non-existent component} -body {
+    set result ""
+
+    ::itcl::extendedclass dog {
+        delegate method foo to bar
+    }
+
+    dog fido
+} -returnCodes {
+    error
+} -cleanup {
+   dog destroy
+} -result {::dog ::fido delegates method "foo" to undefined component "bar"}
+
+test delegatemethod-1.2 {delegating to existing component} -body {
+    ::itcl::extendedclass dog {
+	component string
+        delegate method length to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {3}
+
+test delegatemethod-1.3 {delegating to existing component with error} -body {
+    ::itcl::extendedclass dog {
+#	component string
+        delegate method length to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo bar
+} -cleanup {
+    ::itcl::delete class dog
+} -returnCodes {
+    error
+} -result {wrong # args: should be "fido length string"}
+
+test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body {
+    ::itcl::extendedclass dog {
+#	component string
+        delegate method * to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {3}
+
+test delegatemethod-1.6a {delegating unknown method to existing component with error} -body {
+    ::itcl::extendedclass dog {
+        component stringhandler
+        delegate method * to stringhandler
+
+        constructor {} {
+            set stringhandler string
+        }
+    }
+
+    dog fido
+    fido foo bar
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -returnCodes {
+    error
+} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
+
+test delegatemethod-1.7 {can't delegate local method: order 1} -body {
+    ::itcl::extendedclass dog {
+        component bar
+        method foo {} {}
+        delegate method foo to bar
+    }
+} -returnCodes {
+    error
+} -result {method "foo" has been defined locally}
+
+test delegatemethod-1.8 {can't delegate local method: order 2} -body {
+    ::itcl::extendedclass dog {
+        component bar
+        delegate method foo to bar
+        method foo {} {}
+    }
+} -returnCodes {
+    error
+} -result {method "foo" has been delegated}
+
+test delegatemethod-1.9 {can't delegate local method: order 2} -body {
+    ::itcl::extendedclass dog {
+        component bar
+        delegate method foo to bar
+        method foo {} {}
+    }
+} -cleanup {
+} -returnCodes {
+    error
+} -result {method "foo" has been delegated}
+
+
+# should be same as above
+if {0} {
+#-----------------------------------------------------------------------
+# Typemethod delegation
+
+test delegatemethod-1.1 {delegate method to non-existent component} -body {
+    set result ""
+
+    ::itcl::extendedclass dog {
+        delegate method foo to bar
+    }
+
+    dog fido
+} -returnCodes {
+    error
+} -cleanup {
+    ::itcl::delete class dog
+} -result {::dog ::fido delegates method "foo" to undefined component "bar"}
+
+test delegatemethod-1.2 {delegating to existing component} -body {
+    ::itcl::extendedclass dog {
+	component string
+        delegate method length to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {3}
+
+test delegatemethod-1.3 {delegating to existing component with error} -body {
+    ::itcl::extendedclass dog {
+#	component string
+        delegate method length to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo bar
+} -cleanup {
+    ::itcl::delete class dog
+} -returnCodes {
+    error
+} -result {wrong # args: should be "fido length string"}
+
+test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body {
+    ::itcl::extendedclass dog {
+#	component string
+        delegate method * to string
+
+        constructor {} {
+            set string string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -result {3}
+
+test delegatemethod-1.6a {delegating unknown method to existing component with error} -body {
+    ::itcl::extendedclass dog {
+        component stringhandler
+        delegate method * to stringhandler
+
+        constructor {} {
+            set stringhandler string
+        }
+    }
+
+    dog fido
+    fido foo bar
+} -cleanup {
+    ::itcl::delete object fido
+    ::itcl::delete class dog
+} -returnCodes {
+    error
+} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}
+
+test delegatemethod-1.7 {can't delegate local method: order 1} -body {
+    ::itcl::extendedclass dog {
+        component bar
+        method foo {} {}
+        delegate method foo to bar
+    }
+} -cleanup {
+} -returnCodes {
+    error
+} -result {method "foo" has been defined locally}
+
+test delegatemethod-1.8 {can't delegate local method: order 2} -body {
+    ::itcl::extendedclass dog {
+        component bar
+        delegate method foo to bar
+        method foo {} {}
+    }
+} -cleanup {
+} -returnCodes {
+    error
+} -result {method "foo" has been delegated}
+
+# end
+}
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/ensemble.test

@@ -0,0 +1,225 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+test ensemble-1.1 {ensemble name must be specified} {
+    list [catch {itcl::ensemble} msg] $msg
+} {1 {wrong # args: should be "itcl::ensemble name ?command arg arg...?"}}
+
+test ensemble-1.2 {creating a new ensemble} {
+    itcl::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} {
+    itcl::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} {
+    set res [catch "test_numbers three x" msg]
+    lappend res [string match "wrong # args*" $msg]
+} {1 1}
+
+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 {
+        itcl::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 {
+        itcl::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 "itcl::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
+"itcl::ensemble test_numbers {foo bar baz}"}}
+
+test ensemble-1.10 {part errors are handled gracefully} {
+    list [catch "itcl::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
+"itcl::ensemble test_numbers {part foo}"}}
+
+test ensemble-1.11 {part argument errors are handled gracefully} {
+    list [catch "itcl::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
+"itcl::ensemble test_numbers {part foo {{}} {}}"}}
+
+test ensemble-2.0 {defining subensembles} {
+    itcl::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 "test_numbers hex subcommand ?arg ...?"}}
+
+test ensemble-2.3a {errors from sub-ensembles
+} -body {
+    list [catch "test_numbers hex" msg] $msg
+} -constraints {
+    needs_frq_1773103
+} -result {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 "test_numbers octal subcommand ?arg ...?"}}
+
+test ensemble-2.6a {errors from sub-ensembles
+} -body {
+    list [catch "test_numbers octal" msg] $msg
+} -constraints {
+    needs_frq_1773103
+} -result {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 {
+        itcl::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} {
+    itcl::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 "test_numbers subcommand ?arg ...?"}}
+
+test ensemble-3.1a {the error handler part shows up as generic "...and"
+} -body {
+    list [catch {test_numbers} msg] $msg
+} -constraints {
+    needs_frq_1773103
+} -result {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}}
+
+::itcl::delete ensemble test_numbers
+
+test ensemble-4.0 {SF Bug 119} -setup {
+    itcl::ensemble foo part sub {} {error bar}
+} -cleanup {
+    unset -nocomplain m o
+    rename foo {}
+} -body {
+    catch {foo sub} m o
+    dict get $o -errorinfo
+} -match glob -result {*itcl ensemble part*}
+
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/general1.test

@@ -0,0 +1,237 @@
+#
+# Tests for general class handling
+# ----------------------------------------------------------------------
+#   AUTHOR:  Wolfgang Großer, Arnulf Wiedemann
+#            wolfgang@grosser-erding.de, arnulf@wiedemann-pri.de
+# ----------------------------------------------------------------------
+#            Copyright (c) Wolfgang Großer, Arnulf Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Test protection with inheritance
+# ----------------------------------------------------------------------
+test general1-1.1 {define classes with different protection} {
+    variable ::test_cd_watch ""
+    itcl::class ClassA {
+	private variable priv privA
+	private variable privA privAA
+	protected variable prov provA
+	public variable pubv pubvA
+
+	constructor {args} {
+		lappend ::test_cd_watch constructorA
+	}
+	private method primA {} {
+		lappend ::test_cd_watch primA
+		set privA Hallo
+		lappend ::test_cd_watch [set priv]
+	}
+	protected method promA {} {
+		lappend ::test_cd_watch promA
+		lappend ::test_cd_watch [set prov]
+	}
+	public method pubmA {} {
+		lappend ::test_cd_watch pubmA
+		lappend ::test_cd_watch [set pubv]
+	}
+        public method doA {args} {eval $args}
+    }
+
+    itcl::class ClassB {
+	inherit ClassA
+
+	private variable priv privB
+	private variable privB privBB
+	protected variable prov provB
+	public variable pubv pubvB
+
+	constructor {args} {
+	    lappend ::test_cd_watch [list constructorB $args]
+	}
+	destructor {
+	    lappend ::test_cd_watch destructorB
+	}
+	private method primB {} {
+	    lappend ::test_cd_watch primB
+	    lappend ::test_cd_watch [set priv]
+	}
+	protected method promB {} {
+	    lappend ::test_cd_watch promB
+	    lappend ::test_cd_watch [set prov]
+	}
+	public method pubmB {} {
+	    lappend ::test_cd_watch pubmB
+	    lappend ::test_cd_watch [set pubv]
+	}
+        public method doB {args} {eval $args}
+        public method chkThis {} { set prov $this }
+    }
+
+    itcl::class ClassC {
+	inherit ClassB
+
+	private variable priv privC
+	protected variable prov provC
+	public variable pubv pubvC
+
+	constructor {args} {
+	    eval ClassB::constructor $args
+	} {
+	    lappend ::test_cd_watch [list "start constructorC" $args]
+            ClassA::constructor $args
+	    lappend ::test_cd_watch [list "end constructorC"]
+	}
+	private method primC {} {
+	    lappend ::test_cd_watch primC
+	    lappend ::test_cd_watch [set priv]
+	}
+	protected method promC {} {
+	    lappend ::test_cd_watch promC
+	    lappend ::test_cd_watch [set prov]
+	}
+	public method pubmC {} {
+	    lappend ::test_cd_watch pubmC
+	    lappend ::test_cd_watch [set pubv]
+	    $this primC
+	}
+	public method pubmC2 {arg1 {arg2 {}} {arg3 xxx}} {
+	    lappend ::test_cd_watch "orig pubmC2"
+	}
+        public method doC {args} {
+            eval $args
+        }
+    }
+} {}
+
+test general1-1.2 {constructor of classA should be called twice} {
+    set ::test_cd_watch ""
+    list [ClassC #auto] [set ::test_cd_watch]
+} {classC0 {constructorA {constructorB {}} {{start constructorC} {}} constructorA {{end constructorC}}}}
+
+test general1-1.3 {body command should not produce error} {
+    set ::test_cd_watch ""
+    list [catch {
+        itcl::body ClassC::pubmC2 {aarg1 {aarg2 {}} {arg3 {xxx}}} {
+            lappend ::test_cd_watch "new body command for pubmC2 [list $aarg1 $aarg2 $arg3]"
+        }
+    } msg] $msg [classC0 pubmC2 Hallo]
+} {0 {} {{new body command for pubmC2 Hallo {} xxx}}}
+
+test general1-1.4 {call of configure} {
+    set ::test_cd_watch ""
+    list [lsort [classC0 configure]]
+} {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC pubvC}}}
+
+test general1-1.5 {call of configure with variable} {
+    set ::test_cd_watch ""
+    list [classC0 configure -pubv Arnulf]
+} {{}}
+
+test general1-1.6 {call of configure to check for changes} {
+    set ::test_cd_watch ""
+    list [lsort [classC0 configure]]
+} {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC Arnulf}}}
+
+test general1-1.7 {call of cget} {
+    set ::test_cd_watch ""
+    list [classC0 cget -pubv]
+} {Arnulf}
+
+test general1-1.8 {private method may not be called} {
+    set ::test_cd_watch ""
+    list [catch {classC0 primC} msg] $msg
+} {1 {bad option "primC": should be one of...
+  classC0 cget -option
+  classC0 chkThis
+  classC0 configure ?-option? ?value -option value...?
+  classC0 doA ?arg arg ...?
+  classC0 doB ?arg arg ...?
+  classC0 doC ?arg arg ...?
+  classC0 isa className
+  classC0 pubmA
+  classC0 pubmB
+  classC0 pubmC
+  classC0 pubmC2 aarg1 ?aarg2? ?arg3?}}
+
+test general1-1.9 {protected method may not be called} {
+    set ::test_cd_watch ""
+    list [catch {classC0 promC} msg] $msg
+} {1 {bad option "promC": should be one of...
+  classC0 cget -option
+  classC0 chkThis
+  classC0 configure ?-option? ?value -option value...?
+  classC0 doA ?arg arg ...?
+  classC0 doB ?arg arg ...?
+  classC0 doC ?arg arg ...?
+  classC0 isa className
+  classC0 pubmA
+  classC0 pubmB
+  classC0 pubmC
+  classC0 pubmC2 aarg1 ?aarg2? ?arg3?}}
+
+test general1-1.10 {can call private and protected methods from within the class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC primC} msg] $msg [catch {classC0 doC promC} msg] $msg
+} {0 {primC privC} 0 {primC privC promC provC}}
+
+test general1-1.11 {*cannot* call private methods of inherited classes} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC primB} msg] $msg [catch {classC0 doC primA} msg] $msg
+} {1 {invalid command name "primB"} 1 {invalid command name "primA"}}
+
+test general1-1.12 {can call protected and public methods of inherited classes} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC promB} msg] $msg [catch {classC0 doC pubmC} msg] $msg [catch {classC0 doC promA} msg] $msg [catch {classC0 doC pubmA} msg] $msg
+} {0 {promB provB} 0 {promB provB pubmC Arnulf primC privC} 0 {promB provB pubmC Arnulf primC privC promA provA} 0 {promB provB pubmC Arnulf primC privC promA provA pubmA pubvA}}
+
+test general1-1.13 {"this" variable} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC doB set $this} msg] $msg
+} {1 {can't read "this": no such variable}}
+
+test general1-1.14 {can indirect calls through middle class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC doB doA primA} msg] $msg [catch {classC0 doC doB doA promA} msg] $msg [catch {classC0 doC doB doA pubmA} msg] $msg
+} {0 {primA privA} 0 {primA privA promA provA} 0 {primA privA promA provA pubmA pubvA}}
+
+test general1-1.15 {*cannot* indirect private calls through middle class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC doB primA} msg] $msg [catch {classC0 doC doB primC} msg] $msg
+} {1 {invalid command name "primA"} 1 {invalid command name "primC"}}
+
+test general1-1.16 {*cannot* indirect protected calls through middle class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC doB promA} msg] $msg [catch {classC0 doC doB promC} msg] $msg
+} {0 {promA provA} 1 {invalid command name "promC"}}
+
+test general1-1.17 {access variables through calls through middle class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC doB set privB} msg] $msg [catch {classC0 doC doB doA set pubv} msg] $msg
+} {0 privBB 0 pubvA}
+
+test general1-1.18 {"this" variable} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doB set prov $this} msg] $msg \
+    [catch {classC0 chkThis} msg] $msg
+} {1 {can't read "this": no such variable} 0 ::classC0}
+
+test general1-1.20 {*cannot* read private variable from inherited class} {
+    set ::test_cd_watch ""
+    list [catch {classC0 doC set privA} msg] $msg [catch {classC0 doA set privA} msg] $msg [catch {classC0 doC set privB} msg] $msg [catch {classC0 doB set privB} msg] $msg
+} {1 {can't read "privA": no such variable} 0 Hallo 1 {can't read "privB": no such variable} 0 privBB}
+
+if {0} {
+c publicC
+}
+
+::itcl::delete class ClassA
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/helpers.tcl

@@ -0,0 +1,48 @@
+# helpers.tcl --
+#
+# This file contains helper scripts for all tests, like a mem-leak checker, etc.
+
+# -loadfile overwrites -load, so restore it from ::env(TESTFLAGS):
+if {[info exists ::env(TESTFLAGS)]} {
+  array set testargs $::env(TESTFLAGS)
+  if {[info exists ::testargs(-load)]} {
+    eval $::testargs(-load)
+  }
+  unset testargs
+}
+
+package require itcl
+
+if {[namespace which -command memory] ne "" && (
+    ![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test
+  )
+} {
+  proc getbytes {} {lindex [split [memory info] \n] 3 3}
+  proc leaktest {script {iterations 3}} {
+      set end [getbytes]
+      for {set i 0} {$i < $iterations} {incr i} {
+          uplevel 1 $script
+          set tmp $end
+          set end [getbytes]
+      }
+      return [expr {$end - $tmp}]
+  }
+  proc itcl_leaktest {testfile} {
+    set leak [leaktest [string map [list \
+      @test@ $testfile \
+      @testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}]
+    ] {
+      interp create i
+      load {} Itcl i
+      i eval {set ::tcl::inl_mem_test 0}
+      i eval {package require tcltest; @testargv@}
+      i eval [list source @test@]
+      interp delete i
+    }]]
+    if {$leak} {
+      puts "LEAKED: $leak bytes"
+    }
+  }
+  itcl_leaktest [info script]
+  return -code return
+}

pkgs/itcl4.2.2/tests/import.test

@@ -0,0 +1,184 @@
+#
+# Tests for "auto_import" and autoloading facility
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+set ::itcllib [lindex [lsearch -exact -index 1 -inline [info loaded] Itcl] 0]
+
+# ----------------------------------------------------------------------
+#  Test "itcl::import::stub" command
+# ----------------------------------------------------------------------
+test import-1.1 {basic syntax for "stub" command} {
+    list [catch {itcl::import::stub} result] $result
+} {1 {wrong # args: should be "itcl::import::stub subcommand ?arg ...?"}}
+
+test import-1.1a {basic syntax for "stub" command
+} -body {
+    list [catch {itcl::import::stub} result] $result
+} -constraints {
+    needs_frq_1773103
+} -result {1 {wrong # args: should be one of...
+  stub create name
+  stub exists name}}
+
+test import-1.2 {"stub create" requires one argument} {
+    list [catch {itcl::import::stub create} result] $result \
+         [catch {itcl::import::stub create x y} result] $result
+} {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}}
+
+test import-1.3 {"stub exists" requires one argument} {
+    list [catch {itcl::import::stub exists} result] $result \
+         [catch {itcl::import::stub exists x y} result] $result
+} {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}}
+
+set interp [interp create]
+$interp eval {set ::tcl::inl_mem_test 0}
+$interp eval "
+    [list ::load $::itcllib Itcl]
+    [::tcltest::configure -load]
+    proc auto_load {cmd {namespace {}}} {
+        global debug
+        proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
+        append debug \"(auto_load: \$cmd)\"
+        return 1
+    }
+"
+
+test import-1.4 {"stub create" creates a stub that triggers autoloading} {
+    $interp eval {
+        set debug ""
+        list [itcl::import::stub create foo::bar::test] \
+             [info commands ::foo::bar::test] \
+             [::foo::bar::test 1 2 3] \
+             $debug
+    }
+} {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}}
+
+test import-1.5 {"stub exists" recognizes stubs created by "stub create"} {
+    $interp eval {
+        set debug ""
+        itcl::import::stub create foo::bar::stub1
+        proc foo::bar::proc1 {{args {}}} {return "proc1: $args"}
+        list [itcl::import::stub exists foo::bar::stub1] \
+             [itcl::import::stub exists foo::bar::proc1]
+    }
+} {1 0}
+
+test import-1.6 {stubs can be autoloaded and replaced} {
+    $interp eval {
+        set debug ""
+        itcl::import::stub create foo::bar::stub2
+        list [itcl::import::stub exists foo::bar::stub2] \
+             [::foo::bar::stub2 a b c] \
+             [itcl::import::stub exists foo::bar::stub2] \
+             [::foo::bar::stub2 a b c] \
+             $debug
+    }
+} {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}}
+
+catch {interp delete $interp}
+
+# ----------------------------------------------------------------------
+#  Test "itcl::import::stub" command
+# ----------------------------------------------------------------------
+set interp [interp create]
+$interp eval {set ::tcl::inl_mem_test 0}
+$interp eval "
+    [list ::load $::itcllib Itcl]
+    [::tcltest::configure -load]
+    proc auto_load {cmd {namespace {}}} {
+        proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
+        return 1
+    }
+"
+
+test import-2.1 {initialize some commands for autoloading} {
+    $interp eval {
+        namespace eval test {
+            namespace export foo*
+        }
+        itcl::import::stub create ::test::foo1
+        itcl::import::stub create ::test::foo2
+        lsort [info commands ::test::*]
+    }
+} {::test::foo1 ::test::foo2}
+
+test import-2.2 {stubs can be imported into other namespaces} {
+    $interp eval {
+        namespace eval user1 { namespace import ::test::* }
+        namespace eval user2 { namespace import ::test::* }
+        namespace eval user3 { namespace import ::test::* }
+        list [lsort [info commands ::user1::*]] \
+             [namespace origin ::user1::foo1] \
+             [namespace origin ::user1::foo2]
+    }
+} {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2}
+
+test import-2.3 {stubs can be autoloaded and imported links remain} {
+    $interp eval {
+        list [::user1::foo1 1 2 3 4] \
+             [namespace origin ::user1::foo1] \
+             [namespace origin ::user2::foo1] \
+             [namespace origin ::user3::foo1] \
+             [itcl::import::stub exists ::test::foo1]
+    }
+} {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0}
+
+test import-2.4 {itcl::class handles stubs correctly
+} -body {
+    $interp eval {
+        proc auto_load {cmd {namespace {}}} {
+            itcl::class $cmd { }
+            return 1
+        }
+        list [::user2::foo2 x] \
+             [x info class] \
+             [namespace origin ::user1::foo2] \
+             [namespace origin ::user2::foo2] \
+             [namespace origin ::user3::foo2] \
+             [itcl::import::stub exists ::test::foo2]
+    }
+} -constraints {
+    only_working_in_itcl3.4
+} -result {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0}
+
+test import-2.5 {itcl::class will overwrite stubs in an existing namespace} {
+    $interp eval {
+        proc auto_load {cmd {namespace {}}} {
+            itcl::class $cmd { }
+            return 1
+        }
+        namespace eval test::buried { }
+        itcl::import::stub create ::test::buried
+        itcl::import::stub create ::test::buried::stub
+        list [catch {::test::buried xx} result] $result [xx info class]
+    }
+} {0 xx ::test::buried}
+
+test import-2.6 {itcl::class will overwrite stubs} {
+    $interp eval {
+        proc auto_load {cmd {namespace {}}} {
+            itcl::class $cmd { }
+            return 1
+        }
+        itcl::import::stub create ::test::zonk
+        list [catch {::test::zonk yy} result] $result [yy info class]
+    }
+} {0 yy ::test::zonk}
+
+catch {interp delete $interp}
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/info.test

@@ -0,0 +1,425 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Class definition with one of everything
+# ----------------------------------------------------------------------
+test info-1.1 {define a simple class} {
+    itcl::class test_info_base {
+        method base {} {return "default"}
+        variable base {}
+
+        method do {args} {eval $args}
+    }
+    itcl::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? ?-scope?
+...and others described on the man page}}
+
+test info-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? ?-scope?
+...and others described on the man page}}
+
+test info-1.4 {info: info class works on class itself} {
+    namespace eval test_info { info class }
+} {::test_info}
+
+# ----------------------------------------------------------------------
+#  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} -body {
+    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] \
+         [ti info variable pubv -scope] \
+} -match glob -result {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public ::itcl::internal::variables::oo::Obj*::test_info::pubv}
+
+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} -body {
+    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] \
+         [ti info variable prov -scope] \
+} -match glob -result {protected variable ::test_info::prov protected new-protected ::itcl::internal::variables::oo::Obj*::test_info::prov}
+
+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} -body {
+    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] \
+         [ti info variable priv -scope] \
+} -match glob -result {private variable ::test_info::priv private new-private ::itcl::internal::variables::oo::Obj*::test_info::priv}
+
+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 <undefined> <undefined>}
+
+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] \
+         [ti info variable pubc -scope] \
+} {public common ::test_info::pubc public new-public ::test_info::pubc}
+
+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] \
+         [ti info variable proc -scope] \
+} {protected common ::test_info::proc protected new-protected ::itcl::internal::variables::test_info::proc}
+
+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] \
+         [ti info variable pric -scope] \
+} {private common ::test_info::pric private new-private ::itcl::internal::variables::test_info::pric}
+
+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 <undefined> <undefined>}
+
+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, -value, or -scope}}
+
+# ----------------------------------------------------------------------
+#  Member functions
+# ----------------------------------------------------------------------
+test info-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 <undefined> <undefined>}
+
+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} <undefined>}
+
+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.2c {query inheritance info} {
+    ti do ti 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.3c {query heritage info} {
+    ti do ti info heritage
+} {::test_info ::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
+} {<undefined>}
+
+test info-4.4d {query argument list of real proc} {
+    ti info args ::unknown
+} {args}
+
+test info-4.4e {query argument list of real proc} {
+    itcl::builtin::Info args ::unknown
+} {args}
+
+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
+} {<undefined>}
+
+# ----------------------------------------------------------------------
+#  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}
+
+test info-6.0 {Bug a03f579f7d} -setup {
+    # Must not segfault
+    itcl::class C {
+	proc p {} {info vars}
+    }
+} -body {
+    C::p
+} -cleanup {
+    itcl::delete class C
+} -result {}
+
+# ----------------------------------------------------------------------
+#  Clean up
+# ----------------------------------------------------------------------
+itcl::delete class test_info test_info_base
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/inherit.test

@@ -0,0 +1,591 @@
+#
+# Tests for inheritance and scope handling
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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 [itcl::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 [itcl::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 [itcl::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} knownBug {
+    global errorInfo test_cd_watch
+    set test_cd_watch ""
+    itcl::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
+"::itcl::parser::handleClass test_cd_mongrel ::test_cd_mongrel #auto bob"
+    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
+    itcl::body test_cd_bar::constructor {args} {return "bar: $args"}
+    itcl::body test_cd_bar::destructor {} {error "bar: failed"}
+    test_cd_mongrel mongrel1 ted
+    set test_cd_watch ""
+    list [catch {itcl::delete object mongrel1} msg] $msg \
+        $errorInfo $test_cd_watch [itcl::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
+"itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1}
+
+test inherit-1.10 {errors during destruction prevent class delete} {
+    itcl::body test_cd_bar::destructor {} {error "bar: failed"}
+    test_cd_mongrel mongrel2 xxx
+    list [catch {itcl::delete class test_cd_foo} msg] $msg
+} {1 {bar: failed}}
+
+eval namespace delete [itcl::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 [itcl::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 [itcl::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} {
+    itcl::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 [itcl::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 [itcl::find objects -class test_cd_foo]
+} {test_cd_foo0 test_cd_foo1}
+
+test inherit-5.4 {find objects: -class qualifier} {
+    lsort [itcl::find objects -class test_cd_mongrel]
+} {test_cd_mongrel0}
+
+test inherit-5.5 {find objects: -isa qualifier} {
+    lsort [itcl::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 [itcl::find objects -isa test_cd_mongrel]
+} {test_cd_mongrel0}
+
+test inherit-5.7 {find objects: name qualifier} {
+    lsort [itcl::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 [itcl::find objects -isa test_cd_foo -class test_cd_foobar]
+} {test_cd_foobar0}
+
+test inherit-5.9 {find objects: -isa and name qualifiers} {
+    lsort [itcl::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 {itcl::find objects -xyzzy value} msg] $msg
+} {1 {wrong # args: should be "itcl::find objects ?-class className? ?-isa className? ?pattern?"}}
+
+eval namespace delete [itcl::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} {
+    #
+    # NOTE: For tcl8.2.3 and earlier the stack trace will have
+    #       'invoked from within "eval $args"' for the first eval
+    #       statement.  For later versions, it does not.  Use
+    #       string match to reduce the sensitivity to that.
+    #
+    list [catch {
+        test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error"
+    } msg] $msg [string match {some error
+    ("eval" body line 1)*
+    (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""} [set ::errorInfo]]
+} {1 test 1}
+
+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 [itcl::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"}}
+
+::itcl::delete class test_inherit_base1 test_inherit_base2
+
+# ----------------------------------------------------------------------
+#  Multiple base class error detection
+# ----------------------------------------------------------------------
+test inherit-8.1 {cannot inherit from the same base class more than once} {
+    itcl::class test_mi_base {}
+    itcl::class test_mi_foo {inherit test_mi_base}
+    itcl::class test_mi_bar {inherit test_mi_base}
+    list [catch {
+        itcl::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}}
+
+itcl::delete class test_mi_base
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/interp.test

@@ -0,0 +1,88 @@
+#
+# Tests for using [incr Tcl] in child interpreters
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Make sure that child interpreters can be created and loaded
+#  with [incr Tcl]...
+# ----------------------------------------------------------------------
+test interp-1.1 {create a child interp with [incr Tcl]} {
+    interp create child
+    load "" Itcl child
+    list [child eval "namespace children :: itcl"] [interp delete child]
+} {::itcl {}}
+
+test interp-1.2 {create a safe child interp with [incr Tcl]} {
+    interp create -safe child
+    load "" Itcl child
+    list [child eval "namespace children :: itcl"] [interp delete child]
+} {::itcl {}}
+
+test interp-1.3 {errors are okay when child interp is deleted} {
+catch {interp delete child}
+    interp create child
+    load "" Itcl child
+    child eval {
+        itcl::class Troublemaker {
+            destructor { error "cannot delete this object" }
+        }
+        itcl::class Foo {
+            variable obj ""
+            constructor {} {
+                set obj [Troublemaker #auto]
+            }
+            destructor {
+                delete object $obj
+            }
+        }
+        Foo f
+    }
+    interp delete child
+} {}
+
+test interp-1.4 {one namespace can cause another to be destroyed} {
+    interp create child
+    load "" Itcl child
+    child eval {
+        namespace eval group {
+            itcl::class base1 {}
+            itcl::class base2 {}
+        }
+        itcl::class TroubleMaker {
+            inherit group::base1 group::base2
+        }
+    }
+    interp delete child
+} {}
+
+test interp-1.5 {cleanup interp object list, this should not
+        include an object that deletes itself in ctor} {
+    interp create child
+    load "" Itcl child
+    child eval {
+        itcl::class DeleteSelf {
+            constructor {} {
+                itcl::delete object $this
+            }
+        }
+        DeleteSelf ds
+    }
+    interp delete child
+} {}
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/local.test

@@ -0,0 +1,70 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Test "local" to create objects that only exist within a proc
+# ----------------------------------------------------------------------
+test local-1.1 {define a class to use for testing} {
+    itcl::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 {} {
+            itcl::local test_local #auto
+            lappend status "processing"
+        }
+        proc test2 {} {
+            itcl::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 {} {
+    itcl::find objects -isa test_local
+} {test_local0}
+
+itcl::delete class test_local
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/methods.test

@@ -0,0 +1,206 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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"
+        }
+        method clash_time {x bang boom} {
+            time {set result "clash_time: $x $bang $boom"} 1
+            return $result
+        }
+        proc crash {x bang boom} {
+            return "crash: $x $bang $boom"
+        }
+        proc crash_time {x bang boom} {
+            time {set result "crash_time: $x $bang $boom"} 1
+            return $result
+        }
+        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}
+
+test methods-1.11 {formal args don't clobber class members, even in "time"} {
+    list [catch {ta clash_time 7 8 9} msg] $msg \
+         [ta info variable bang -value] \
+         [ta info variable boom -value]
+} {0 {clash_time: 7 8 9} ok no-problem}
+
+test methods-1.12 {formal args don't clobber class members, even in "time"} {
+    list [catch {test_args::crash_time a b c} msg] $msg \
+         [ta info variable bang -value] \
+         [ta info variable boom -value]
+} {0 {crash_time: a b c} ok no-problem}
+
+test methods-2.1 {covers leak condition test for compiled locals, no args} {
+    for {set i 0} {$i < 100} {incr i} {
+	::itcl::class LeakClass {
+            proc leakProc {} { set n 1 }
+	}
+	LeakClass::leakProc
+	::itcl::delete class LeakClass
+    }
+    list 0
+} 0
+test methods-2.2 {covers leak condition test for nested methods calls within eval, bug [8e632ce049]} -setup {
+    itcl::class C1 {
+	proc factory {} {
+	    set obj [C1 #auto]
+	    $obj myeval [list $obj read]
+	    itcl::delete object $obj
+	}
+	method myeval {script} { eval $script }
+	method read {} { myeval {} }
+    }
+} -body {
+    time { C1::factory } 50
+    list 0
+} -result 0 -cleanup {
+    itcl::delete class C1
+}
+test methods-2.3 {call of method after object is destroyed inside other methods, SF-bug [c1289b1c32]} -setup {
+    proc c1test {} {
+	return c1test
+    }
+    itcl::class C1 {
+	public method m1 {} {
+	    itcl::delete object $this
+	    c1test
+	}
+	public method m2 {} {
+	    rename $this {}
+	    c1test
+	}
+	public method c1test {} {
+	   return C1::c1test
+	}
+    }
+} -body {
+    set result {}
+    set obj [C1 #auto]
+    lappend result [catch {$obj m1} v] $v [namespace which -command $obj]
+    set obj [C1 #auto]
+    lappend result [catch {$obj m2} v] $v [namespace which -command $obj]
+} -match glob -result {1 * {} 1 * {}} -cleanup {
+    itcl::delete class C1
+    rename c1test {}
+}
+
+# ----------------------------------------------------------------------
+#  Clean up
+# ----------------------------------------------------------------------
+itcl::delete class test_args
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/mkindex.itcl

@@ -0,0 +1,83 @@
+# 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 itcl::*
+
+class Simple1 {
+    variable x 0
+    public method bump {} {incr x}
+}
+  itcl::class Simple2 {
+    variable x 0
+    public variable by 1
+    public method bump {}
+  }
+
+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 { }
+    }
+}

pkgs/itcl4.2.2/tests/mkindex.test

@@ -0,0 +1,57 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+set ::tcl::inl_mem_test 0
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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} {
+    if {[pwd] != $::tcltest::testsDirectory} {
+	file copy -force [file join $::tcltest::testsDirectory mkindex.itcl] \
+		./mkindex.itcl
+    }
+    auto_mkindex . mkindex.itcl
+    if {[pwd] != $::tcltest::testsDirectory} {
+	file delete -force ./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} {Simple1 $element} {Simple2 $element} {ens $element} {top $element}"
+
+file delete tclIndex
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/namespace.test

@@ -0,0 +1,100 @@
+#
+# Tests for classes within namespaces
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.2
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  Classes within namespaces
+# ----------------------------------------------------------------------
+test namespace-1.1 {same class name can be used in different namespaces
+} -body {
+    namespace eval test_ns_1 {
+        itcl::class Counter {
+            variable num 0
+            method ++ {{by 1}} {
+                incr num $by
+            }
+            method do {args} {
+                return [eval $args]
+            }
+            common tag 1
+        }
+        proc exists {} { return "don't clobber me!" }
+    }
+    namespace eval test_ns_2 {
+        itcl::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
+        }
+    }
+} -result {}
+
+test namespace-1.2 {classes in different namespaces are different
+} -body {
+    list [namespace eval test_ns_1::Counter {info variable tag}] \
+         [namespace eval test_ns_2::Counter {info variable tag}] \
+} -result {{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
+} -body {
+    namespace eval test_ns_1 {
+        list [Counter c] [c ++] [c ++] [c ++] [c ++]
+    }
+} -result {c 1 2 3 4}
+
+test namespace-1.4 {create an object in another namespace
+} -body {
+    namespace eval test_ns_2 {
+        list [Counter c] [c ++] [c ++] [c ++] [c ++]
+    }
+} -cleanup {
+    namespace delete ::itcl::internal::variables::test_ns_2
+    namespace delete test_ns_2
+} -result {c 1 2 4 8}
+
+test namespace-1.5 {can find classes wrapped in a namespace
+} -body {
+    list [catch {test_ns_1::c do itcl::find objects -isa Counter} msg] $msg \
+         [catch {test_ns_1::c do itcl::find objects -class Counter} msg] $msg
+} -result {0 ::test_ns_1::c 0 ::test_ns_1::c}
+
+test namespace-1.6 {can't create an object that clobbers a command in this namespace
+} -body {
+    list [catch {namespace eval test_ns_1 {Counter exists}} msg] $msg
+} -result {1 {command "exists" already exists in namespace "::test_ns_1"}}
+
+test namespace-1.7 {can create an object that shadows a command in the global namespace
+} -body {
+    list [catch {namespace eval test_ns_1 {Counter lreplace}} msg] $msg \
+         [catch {itcl::find objects *lreplace} msg] $msg \
+         [namespace eval test_ns_1 {namespace which lreplace}]
+} -cleanup {
+    namespace delete ::itcl::internal::variables::test_ns_1
+    namespace delete test_ns_1
+} -result {0 lreplace 0 ::test_ns_1::lreplace ::test_ns_1::lreplace}
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/protection.test

@@ -0,0 +1,374 @@
+#
+# 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
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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 [itcl::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 [itcl::find classes test_info*]
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/scope.test

@@ -0,0 +1,227 @@
+#
+# Tests for code/scope commands
+# ----------------------------------------------------------------------
+#   AUTHOR:  Michael J. McLennan
+#            Bell Labs Innovations for Lucent Technologies
+#            mmclennan@lucent.com
+#            http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+#            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.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+# ----------------------------------------------------------------------
+#  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} -body {
+    list [test_scope0 mcontext itcl::scope priv] \
+         [test_scope::pcontext itcl::scope pric]
+} -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::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 [uplevel 0 $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} -body {
+    test_scope0 mcontext set varray(0) "defined"
+    test_scope::pcontext set carray(0) "defined"
+    list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \
+         [catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \
+         [catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \
+         [catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg
+} -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::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 itcl::scope array(0)} msg] $msg \
+         [catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg
+} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}
+
+namespace delete test_scope_ns
+
+test scope-5.0 {Bug e5f529da75} -setup {
+    itcl::class B {
+	common c
+	method v {} {itcl::scope c}
+    }
+    itcl::class D {
+	inherit B
+	method v {} {itcl::scope c}
+    }
+    B b
+    D d
+} -body {
+    string equal [b v] [d v]
+} -cleanup {
+    itcl::delete class B
+} -result 1
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/sfbugs.test

@@ -0,0 +1,680 @@
+#
+# Tests for SF bugs
+# ----------------------------------------------------------------------
+#   AUTHOR:  Arnulf Wiedemann
+#            arnulf@wiedemann-pri.de
+# ----------------------------------------------------------------------
+#            Copyright (c) Arnulf Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2.1
+namespace import ::tcltest::test
+::tcltest::loadTestedCommands
+package require itcl
+
+global ::test_status
+
+# ----------------------------------------------------------------------
+#  Test bugs of the SourceForge bug tracker for incrtcl
+# ----------------------------------------------------------------------
+
+test sfbug-163 {upvar has to resolve instance variables in caller} -setup {
+    itcl::class o1 {
+        public method getValue {name} {
+	    upvar $name val
+	    set val 22
+	}
+    }
+    itcl::class o2 {
+	public variable command
+	constructor {cls2} {
+	    $cls2 getValue command
+	}
+	public method b {cls2} {
+	    return $command
+	}
+    }
+    o1 test1
+    o2 test2 test1
+} -body {
+    test2 b test1
+} -cleanup {
+    itcl::delete class o2
+    itcl::delete class o1
+} -result 22
+
+test sfbug-187 {upvar with this variable SF bug #187
+} -body {
+    ::itcl::class foo {
+      method test {} {
+          PopID
+      }
+
+      proc PopID {} {
+        upvar 1 this me
+        set me
+      }
+    }
+    foo bar
+    bar test
+} -result {::bar} \
+  -cleanup {::itcl::delete class foo}
+
+test sfbug-234 {chain with no argument SF bug #234
+} -body {
+    set ::test_status ""
+    itcl::class One {
+	public method t1 {x} {
+            lappend ::test_status "$this One.t1($x)"
+	}
+	public method t2 {} {
+            lappend ::test_status "$this One.t2"
+	}
+    }
+
+    itcl::class Two {
+        inherit One
+
+        public method t1 {x} {
+            lappend ::test_status "$this Two.t1($x)"
+            chain $x
+        }
+
+        public method t2 {} {
+            lappend ::test_status "$this Two.t2"
+            chain
+        }
+    }
+    set y [Two #auto]
+    $y t1 a
+    $y t2
+} -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \
+  -cleanup {::itcl::delete class Two}
+
+test sfbug-236 {problem with inheritance of methods SF bug #236
+} -body {
+    set ::test_status ""
+
+    ::itcl::class c_mem {
+        private method get_ports {}
+        public method get_mem {}
+    }
+
+    ::itcl::class c_rom {
+        inherit c_mem
+        private method get_ports {}
+    }
+
+    ::itcl::body c_rom::get_ports {} {
+        return "toto"
+    }
+
+    ::itcl::body c_mem::get_ports {} {
+        return "tata"
+    }
+
+    ::itcl::body c_mem::get_mem {} {
+        return [concat "titi" [get_ports]]
+    }
+
+    set ptr [c_rom #auto]
+    lappend ::test_status [$ptr get_mem]
+
+# expected output:
+# titi toto
+} -result {{titi toto}} \
+  -cleanup {::itcl::delete class c_rom}
+
+test sfbug-237 { problem with chain command SF bug #237
+} -body {
+    set ::test_status ""
+
+    itcl::class main {
+        constructor {} {
+            lappend ::test_status "OK ITCL constructor"
+	}
+
+        public method init_OK1 { parm } {
+            lappend ::test_status "OK1 MAIN $parm"
+        }
+        public method init_OK2 {} {
+            lappend ::test_status "OK2 MAIN"
+        }
+        public method init_ERR1 {} {
+            lappend ::test_status "ERR1 MAIN"
+        }
+    }
+
+    itcl::class child {
+        inherit main
+
+        constructor {} {}
+
+        public method init_OK1 {} {
+            lappend ::test_status "OK1 CHILD"
+            chain TEST
+        }
+
+        public method init_OK2 {} {
+            lappend ::test_status "OK2 CHILD"
+            next
+        }
+
+        public method init_ERR1 {} {
+            lappend ::test_status "ERR1 CHILD"
+            chain
+        }
+    }
+
+    set obj [child #auto]
+    $obj init_OK1
+    $obj init_OK2
+    $obj init_ERR1
+} -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \
+  -cleanup {::itcl::delete class child}
+
+test sfbug-243 {faulty namespace behaviour SF bug #243
+} -body {
+    set ::test_status ""
+
+    namespace eval ns {}
+
+    itcl::class ns::A {
+        method do {} {nsdo}
+
+        method nsdo {} {
+            lappend ::test_status "body do: [info function do -body]"
+        }
+    }
+
+    [ns::A #auto] do
+
+    itcl::body ns::A::do {} {A::nsdo}
+    [ns::A #auto] do
+
+    itcl::body ns::A::do {} {::ns::A::nsdo}
+    [ns::A #auto] do
+
+    itcl::body ns::A::do {} {ns::A::nsdo}
+    [ns::A #auto] do
+} -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \
+  -cleanup {::itcl::delete class ns::A}
+
+test sfbug-244 { SF bug 244
+} -body {
+    set ::test_status ""
+
+    proc foo {body} {
+        uplevel $body
+    }
+
+    itcl::class A {
+      method do {body} {foo $body}
+      method do2 {} {lappend ::test_status done}
+    }
+
+    set y [A #auto]
+    $y  do {
+        lappend ::test_status "I'm $this"
+        do2
+    }
+} -result {{I'm ::a0} done} \
+  -cleanup {::itcl::delete class A; rename foo {}}
+
+test sfbug-250 { SF bug #250
+} -body {
+    set ::test_status ""
+
+    ::itcl::class A {
+        variable b
+
+        constructor {} {
+            set b [B #auto]
+        }
+
+        public method m1 {} {
+            $b m3
+        }
+
+        public method m2 {} {
+            lappend ::test_status m2
+        }
+    }
+
+    ::itcl::class B {
+        public method m3 {} {
+          uplevel m2
+         }
+    }
+
+    set a [A #auto]
+    $a m1
+
+} -result {m2} \
+  -cleanup {::itcl::delete class A B}
+
+test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx
+} -body {
+    set ::test_status ""
+
+    itcl::class foo {
+        method kerplunk {args} {
+            lappend ::test_status [info level 0]
+            lappend ::test_status [::info level 0]
+            lappend ::test_status [[namespace which info] level 0]
+       }
+    }
+
+    [foo #auto] kerplunk hello world
+} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
+  -cleanup {::itcl::delete class foo}
+
+test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb]
+} -body {
+    set interp [interp create]
+    set ::test_status ""
+    $interp eval {
+      oo::class destroy
+    }
+    lappend ::test_status "::oo::class destroy worked"
+    if {[catch {
+      $interp eval [::tcltest::loadScript]
+      $interp eval {
+        package require itcl
+      }
+    } msg]} {
+      lappend ::test_status $msg
+    }
+} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \
+  -cleanup {interp delete $interp}
+
+test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb]
+} -body {
+    set interp [interp create]
+    set ::test_status ""
+    $interp eval {set ::tcl::inl_mem_test 0}
+    $interp eval [::tcltest::loadScript]
+    $interp eval {
+      package require itcl
+
+      oo::class destroy
+    }
+    lappend ::test_status "::oo::class destroy worked"
+    if {[catch {
+      $interp eval {
+        ::itcl::class ::test {}
+      }
+    } msg]} {
+      lappend ::test_status $msg
+    }
+} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \
+  -cleanup {interp delete $interp}
+
+test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb]
+} -body {
+    set interp [interp create]
+    set ::test_status ""
+    $interp eval {set ::tcl::inl_mem_test 0}
+    $interp eval [::tcltest::loadScript]
+    $interp eval {
+      package require itcl
+
+      ::itcl::class ::test {}
+    }
+    lappend ::test_status "::test class created"
+    $interp eval {
+      oo::class destroy
+    }
+    lappend ::test_status "::oo::class destroy worked"
+    if {[catch {
+      $interp eval {
+        ::test x
+      }
+    } msg]} {
+      lappend ::test_status $msg
+    }
+    if {[catch {
+      $interp eval {
+        ::itcl::class ::test2 {inherit ::test}
+      }
+    } msg]} {
+      lappend ::test_status $msg
+    }
+} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \
+  -cleanup {interp delete $interp}
+
+test sfbug-255 { SF bug #255
+} -body {
+    set ::test_status ""
+
+    proc ::sfbug_255_do_uplevel { body } {
+        uplevel 1 $body
+    }
+
+    proc ::sfbug_255_testclass { pathName args } {
+        uplevel TestClass $pathName $args
+    }
+
+    ::itcl::class TestClass {
+        public variable property "value"
+        constructor {} {
+        }
+
+        private method internal-helper {} {
+            return "TestClass::internal-helper"
+        }
+
+        public method api-call {} {
+            lappend ::test_status "TestClass::api-call"
+            lappend ::test_status [internal-helper]
+            lappend ::test_status [sfbug_255_do_uplevel { internal-helper }]
+            lappend ::test_status [cget -property]
+            sfbug_255_do_uplevel { lappend ::test_status [cget -property] }
+        }
+    }
+
+    [::sfbug_255_testclass tc] api-call
+} -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \
+  -cleanup {::itcl::delete class TestClass}
+
+test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23
+} -body {
+    ::itcl::class ::Naughty {
+        private method die {} {
+        }
+    }
+    ::Naughty die
+} -cleanup {
+    ::itcl::delete class ::Naughty
+} -result {die}
+
+test sfbug-256 { SF bug #256
+} -body {
+    set ::test_status ""
+
+    proc ::sfbug_256_do_uplevel { body } {
+        uplevel 1 $body
+    }
+
+    proc ::sfbug_256_testclass { pathName args } {
+        uplevel TestClass256 $pathName $args
+    }
+
+    ::itcl::class TestClass256 {
+        public variable property "value"
+        constructor {} {
+        }
+
+        private method internal-helper {} {
+            lappend ::test_status "TestClass::internal-helper"
+            sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
+        }
+
+        public method api-call {} {
+            lappend ::test_status "TestClass::api-call"
+            lappend ::test_status [internal-helper]
+            lappend ::test_status [sfbug_256_do_uplevel { internal-helper }]
+            lappend ::test_status [cget -property]
+            sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
+        }
+    }
+
+    [::sfbug_256_testclass tc] api-call
+} -result {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value} value value} \
+  -cleanup {::itcl::delete class TestClass256}
+
+test sfbug-257 { SF bug #257
+} -body {
+    set interp [interp create]
+    $interp eval {set ::tcl::inl_mem_test 0}
+    $interp eval [::tcltest::loadScript]
+    $interp eval {
+      package require itcl
+      set ::test_status ""
+      ::itcl::class ::cl1 {
+        method m1 {} {
+          ::oo::class destroy
+          lappend ::test_status "method Hello World"
+        }
+        proc p1 {} {
+          lappend ::test_status "proc Hello World"
+        }
+      }
+      set obj1 [::cl1 #auto]
+      ::cl1::p1
+      $obj1 p1
+      $obj1 m1
+
+      catch {
+      $obj1 m1
+      ::cl1::p1
+      } msg
+      lappend ::test_status $msg
+    }
+} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
+  -cleanup {interp delete $interp}
+
+test sfbug-259 { SF bug #257 } -setup {
+    interp create child
+    load {} Itcl child
+} -cleanup {
+    interp delete child
+} -body {
+    child eval {
+proc do_uplevel { body } {
+    uplevel 1 $body
+}
+proc ::testclass { pathName args } {
+    uplevel TestClass $pathName $args
+}
+itcl::class TestClass {
+    constructor {} {}
+    public variable property "value"
+    public method api-call {}
+    protected method internal-helper {}
+}
+itcl::body TestClass::internal-helper {} {
+}
+itcl::configbody TestClass::property {
+    internal-helper
+}
+itcl::body TestClass::api-call {} {
+    do_uplevel {configure -property blah}
+}
+set tc [::testclass .]
+$tc api-call
+    }
+}
+
+test sfbug-261 { SF bug #261 } -setup {
+    itcl::class A {
+	public method a1 {} {a2}
+	public method a2 {} {uplevel a3 hello}
+	public method a3 {s} {return $s}
+    }
+    A x
+} -body {
+    x a1
+} -cleanup {
+    itcl::delete class A
+} -result hello
+
+test sfbug-265.1 { SF bug #265 } -setup {
+    itcl::class C {}
+} -body {
+    namespace eval A {C c}
+    namespace eval B {C c}
+} -cleanup {
+    itcl::delete class C
+    namespace delete A B
+} -result c
+test sfbug-265.2 { SF bug #265 } -setup {
+    itcl::class C {}
+    itcl::class B::C {}
+} -body {
+    C ::A::B
+    B::C ::A
+} -cleanup {
+    itcl::delete class B::C
+    itcl::delete class C
+    namespace delete A B
+} -result ::A
+
+test sfbug-268 { SF bug #268 } -setup {
+    itcl::class C {
+	private variable v
+	destructor {error foo}
+	public method demo {} {set v 0}
+    }
+    C c
+} -body {
+    catch {itcl::delete object c}
+    c demo
+} -cleanup {
+    rename c {}
+    itcl::delete class C
+} -result 0
+
+test sfbug-273 { SF bug #273 } -setup {
+    itcl::class C {
+	public proc call {m} {$m}
+	public proc crash {} {
+	    call null
+	    info frame 2
+	    return ok
+	}
+	public proc null {} {}
+    }
+} -body {
+    C::call crash
+} -cleanup {
+    itcl::delete class C
+} -result ok
+
+
+test sfbug-276.0 { SF bug #276 } -setup {
+  set ::answer {}
+  itcl::class A {
+    constructor {} {
+      lappend ::answer [uplevel namespace current]
+    }
+  }
+  itcl::class B {
+    inherit A
+    constructor {} {}
+  }
+} -body {
+  B b
+  set ::answer
+} -cleanup {
+  itcl::delete class A B
+  unset -nocomplain ::answer
+} -result ::B
+
+test sfbug-276.1 { SF bug #276 } -setup {
+  set ::answer {}
+  itcl::class A {
+    constructor {} {
+      lappend ::answer [uplevel namespace current]
+    }
+  }
+  itcl::class E {
+    constructor {} {
+      lappend ::answer [uplevel namespace current]
+    }
+  }
+  itcl::class B {
+    inherit A E
+    constructor {} {}
+  }
+} -body {
+  B b
+  set ::answer
+} -cleanup {
+  itcl::delete class A B E
+  unset -nocomplain ::answer
+} -result {::B ::B}
+
+test fossil-9.0 {d0126511d9} -setup {
+    itcl::class N::B {}
+} -body {
+    itcl::class N {}
+} -cleanup {
+    itcl::delete class N::B N
+} -result {}
+
+test fossil-9.1 {d0126511d9} -setup {
+    itcl::class N::B {}
+    itcl::delete class N::B
+    namespace delete N
+} -body {
+    itcl::class N {}
+} -cleanup {
+    itcl::delete class N
+    catch {namespace delete N}
+} -result {}
+
+test fossil-9.2 {ec215db901} -setup {
+    set ::answer {}
+    itcl::class Object {
+	constructor {} {set n 1} {set ::answer $n}
+    }
+} -body {
+    Object foo
+    set ::answer
+} -cleanup {
+    itcl::delete class Object
+    unset -nocomplain ::answer
+} -result 1
+
+test fossil-9.3 {c45384364c} -setup {
+    itcl::class A {
+	method demo script {uplevel 1 $script}
+    }
+    A a
+    itcl::class B {
+	method demo script {eval $script; a demo $script}
+    }
+    B b
+} -body {
+    b demo {lappend result $this}
+} -cleanup {
+    itcl::delete class A B
+} -result {::b ::b}
+
+test fossil-9.4 {9eea4912b9} -setup {
+    itcl::class A {
+	public method foo WRONG
+    }
+} -body {
+    itcl::body A::foo {RIGHT} {}
+    A a
+    a info args foo
+} -cleanup {
+    itcl::delete class A
+} -result RIGHT
+
+test sfbugs-281 {Resolve inherited common} -setup {
+    itcl::class Parent {protected common x 0}
+} -cleanup {
+    itcl::delete class Parent
+} -body {
+    itcl::class Child {
+	inherit Parent
+	set Parent::x
+    }
+} -result {}
+
+
+
+#test sfbug-xxx { SF bug xxx
+#} -body {
+#    set ::test_status ""
+#
+#} -result {::bar} \
+#  -cleanup {::itcl::delete class yyy}
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/tclIndex

@@ -0,0 +1,23 @@
+# 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(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]]

pkgs/itcl4.2.2/tests/typeclass.test

@@ -0,0 +1,606 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typeclass.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code from the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type command.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+interp alias {} type {} ::itcl::type
+
+loadTestedCommands
+
+#-----------------------------------------------------------------------
+# type destruction
+
+test typedestruction-1.1 {type command is deleted} -body {
+    type dog { }
+    dog destroy
+    info command ::dog
+} -result {}
+
+test typedestruction-1.2 {instance commands are deleted} -body {
+    type dog { }
+
+    dog create spot
+    dog destroy
+    info command ::spot
+} -result {}
+
+test typedestruction-1.3 {type namespace is deleted} -body {
+    type dog { }
+    dog destroy
+    namespace exists ::dog
+} -result {0}
+
+test typedestruction-1.4 {type proc is destroyed on error} -body {
+    catch {type dog {
+        error "Error creating dog"
+    }} result
+
+    list [namespace exists ::dog] [info command ::dog]
+} -result {0 {}}
+
+#-----------------------------------------------------------------------
+# type and typemethods
+
+test type-1.1 {type names get qualified} -body {
+    type dog {}
+} -cleanup {
+    dog destroy
+} -result {::dog}
+
+test type-1.2 {typemethods can be defined} -body {
+    type dog {
+        typemethod foo {a b} {
+            return [list $a $b]
+        }
+    }
+
+    dog foo 1 2
+} -cleanup {
+    dog destroy
+} -result {1 2}
+
+test type-1.3 {upvar works in typemethods} -body {
+    type dog {
+        typemethod goodname {varname} {
+            upvar $varname myvar
+            set myvar spot
+        }
+    }
+
+    set thename fido
+    dog goodname thename
+    set thename
+} -cleanup {
+    dog destroy
+    unset thename
+} -result {spot}
+
+test type-1.4 {typemethod args can't include type} -body {
+    type dog {
+        typemethod foo {a type b} { }
+    }
+} -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}
+
+test type-1.5 {typemethod args can't include self} -body {
+    type dog {
+        typemethod foo {a self b} { }
+    }
+} -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}
+
+test type-1.6 {typemethod args can span multiple lines} -body {
+    # This case caused an error at definition time in 0.9 because the
+    # arguments were included in a comment in the compile script, and
+    # the subsequent lines weren't commented.
+    type dog {
+        typemethod foo {
+            a
+            b
+        } { }
+    }
+} -cleanup {
+    dog destroy
+} -result {::dog}
+
+#---------------------------------------------------------------------
+# typeconstructor
+
+test typeconstructor-1.1 {a typeconstructor can be defined} -body {
+    type dog {
+        typevariable a
+
+        typeconstructor {
+            set a 1
+        }
+
+        typemethod aget {} {
+            return $a
+        }
+    }
+
+    dog aget
+} -cleanup {
+    dog destroy
+} -result {1}
+
+test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
+    type dog {
+        typevariable a
+
+        typeconstructor {
+            set a 1
+        }
+
+        typeconstructor {
+            set a 2
+        }
+    }
+} -returnCodes {
+    error
+} -result {"typeconstructor" already defined in class "::dog"}
+
+test typeconstructor-1.3 {type proc is destroyed on error} -body {
+    catch {
+        type dog {
+            typeconstructor {
+                error "Error creating dog"
+            }
+        }
+    } result
+
+    list [namespace exists ::dog] [info command ::dog]
+} -result {0 {}}
+
+#-----------------------------------------------------------------------
+# Type components
+
+test typecomponent-1.1 {typecomponent defines typevariable} -body {
+    type dog {
+        typecomponent mycomp
+
+        typemethod test {} {
+            return $mycomp
+        }
+    }
+
+    dog test
+} -cleanup {
+    dog destroy
+} -result {}
+
+
+test typecomponent-1.4 {typecomponent -inherit yes} -body {
+    type dog {
+        typecomponent mycomp -inherit yes
+
+        typeconstructor {
+            set mycomp string
+        }
+    }
+
+    dog length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+
+#-----------------------------------------------------------------------
+# type creation
+
+test creation-1.1 {type instance names get qualified} -body {
+    type dog { }
+
+    dog create spot
+} -cleanup {
+    dog destroy
+} -result {::spot}
+
+test creation-1.2 {type instance names can be generated} -body {
+    type dog { }
+
+    dog create my#auto
+} -cleanup {
+    dog destroy
+} -result {::mydog0}
+
+test creation-1.3 {"create" method is optional} -body {
+    type dog { }
+
+    dog fido
+} -cleanup {
+    dog destroy
+} -result {::fido}
+
+test creation-1.4 {constructor arg can't be type} -body {
+    type dog {
+        constructor {type} { }
+    }
+} -returnCodes {
+    error
+} -result {constructor's arglist may not contain "type" explicitly}
+
+test creation-1.5 {constructor arg can't be self} -body {
+    type dog {
+        constructor {self} { }
+    }
+} -returnCodes {
+    error
+} -result {constructor's arglist may not contain "self" explicitly}
+
+test creation-1.6 {weird names are OK} -body {
+    # I.e., names with non-identifier characters
+    type confused-dog {
+        method meow {} {
+            return "$self meows."
+        }
+    }
+
+    confused-dog spot
+    spot meow
+} -cleanup {
+    confused-dog destroy
+} -result {::spot meows.}
+
+#-----------------------------------------------------------------------
+# renaming
+
+test typeclass-rename-1.1 {mymethod uses name of instance name variable} -body {
+    type dog {
+        method mymethod {} {
+            list [mymethod] [mymethod "A B"] [mymethod A B]
+        }
+    }
+
+    dog fido
+    fido mymethod
+} -cleanup {
+    dog destroy
+} -match glob -result {{::itcl::builtin::callinstance *} {::itcl::builtin::callinstance * {A B}} {::itcl::builtin::callinstance * A B}}
+
+
+test typeclass-rename-1.2 {instances can be renamed} -body {
+    type dog {
+        method names {} {
+            list [mymethod] $selfns $win $self
+        }
+    }
+
+    dog fido
+    set a [fido names]
+    rename fido spot
+    set b [spot names]
+
+    concat $a $b
+} -cleanup {
+    dog destroy
+} -match glob -result {{::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::fido {::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::spot}
+
+test rename-1.3 {rename to "" deletes an instance} -body {
+    type dog { }
+
+    dog fido
+    rename fido ""
+    namespace children ::dog
+} -cleanup {
+    dog destroy
+} -result {}
+
+test rename-1.4 {rename to "" deletes an instance even after a rename} -body {
+    type dog { }
+
+    dog fido
+    rename fido spot
+    rename spot ""
+    namespace children ::dog
+} -cleanup {
+    dog destroy
+} -result {}
+
+test rename-1.5 {creating an object twice destroys the first instance} -body {
+    type dog {
+        typemethod x {} {}
+    }
+
+    dog fido
+    set ns [info object namespace fido]
+    set a [namespace children ::itcl::internal::variables$ns]
+    dog fido
+    set ns [info object namespace fido]
+    set b [namespace children ::itcl::internal::variables$ns]
+    fido destroy
+    set c [namespace which ::itcl::internal::variables$ns]
+
+    list $a $b $c
+} -cleanup {
+    dog destroy
+} -match glob -result {::itcl::internal::variables::*::dog ::itcl::internal::variables::*::dog {}}
+
+
+test typeclass-component-1.1 {component defines variable} -body {
+    type dog {
+        typecomponent mycomp
+
+        public proc test {} {
+            return $mycomp
+        }
+    }
+
+    dog fido
+    fido test
+} -cleanup {
+    fido destroy
+    dog destroy
+} -result {}
+
+test typeclass-component-1.2 {component -inherit} -body {
+    type dog {
+        component mycomp -inherit
+
+        constructor {} {
+            set mycomp string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    fido destroy
+    dog destroy
+} -result {3}
+
+test typeclass-component-1.3 {component -inherit can only have one of it} -body {
+    type dogbase {
+        component mycompbase -inherit
+    }
+
+    type dog {
+	inherit dogbase
+        component mycomp -inherit
+
+        constructor {} {
+            set mycomp string
+        }
+    }
+
+    dog fido
+    fido length foo
+} -cleanup {
+    dog destroy
+    dogbase destroy
+} -returnCodes {
+    error
+} -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"}
+
+#-----------------------------------------------------------------------
+# constructor
+
+
+test constructor-1.1 {constructor can do things} -body {
+    type dog {
+        variable a
+        variable b
+        constructor {args} {
+            set a 1
+            set b 2
+        }
+        method foo {} {
+            list $a $b
+        }
+    }
+
+    dog create spot
+    spot foo
+} -cleanup {
+    dog destroy
+} -result {1 2}
+
+test constructor-1.2 {constructor with no configurelist ignores args} -body {
+    type dog {
+        constructor {args} { }
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot -color white -akc 1
+    list [spot cget -color] [spot cget -akc]
+} -cleanup {
+    dog destroy
+} -result {golden 0}
+
+test constructor-1.3 {constructor with configurelist gets args} -body {
+    type dog {
+        constructor {args} {
+            $self configure {*}$args
+        }
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot -color white -akc 1
+    list [spot cget -color] [spot cget -akc]
+} -cleanup {
+    dog destroy
+} -result {white 1}
+
+test constructor-1.4 {constructor with specific args} -body {
+    type dog {
+        option -value ""
+        constructor {a b args} {
+            set itcl_options(-value) [list $a $b $args]
+        }
+    }
+
+    dog spot retriever golden -akc 1
+    spot cget -value
+} -cleanup {
+    dog destroy
+} -result {retriever golden {-akc 1}}
+
+test constructor-1.5 {constructor with list as one list arg} -body {
+    type dog {
+        option -value ""
+        constructor {args} {
+            set itcl_options(-value) $args
+        }
+    }
+
+    dog spot {retriever golden}
+    spot cget -value
+} -cleanup {
+    dog destroy
+} -result {{retriever golden}}
+
+test constructor-1.6 {default constructor configures options} -body {
+    type dog {
+        option -color brown
+        option -breed mutt
+    }
+
+    dog spot -color golden -breed retriever
+    list [spot cget -color] [spot cget -breed]
+} -cleanup {
+    dog destroy
+} -result {golden retriever}
+
+test constructor-1.7 {default constructor takes no args if no options} -body {
+    type dog {
+	variable color
+    }
+
+    dog spot -color golden
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {type "dog" has no options, but constructor has option arguments}
+
+
+#-----------------------------------------------------------------------
+# destroy
+
+test destroy-1.1 {destroy cleans up the instance} -body {
+    type dog {
+        option -color golden
+    }
+
+    set a [namespace children ::dog::]
+    dog create spot
+    set ns [info object namespace spot]
+    set b [namespace children ::itcl::internal::variables$ns]
+    spot destroy
+    set c [namespace which ::itcl::internal::variables$ns]
+    list $a $b $c [info commands ::dog::spot]
+} -cleanup {
+    dog destroy
+} -match glob -result {{} ::itcl::internal::variables::*::dog {} {}}
+
+test destroy-1.2 {incomplete objects are destroyed} -body {
+    array unset ::dog::snit_ivars
+
+    type dog {
+        option -color golden
+
+        constructor {args} {
+            $self configure {*}$args
+
+            if {"red" == [$self cget -color]} {
+                error "No Red Dogs!"
+            }
+        }
+    }
+
+    catch {dog create spot -color red} result
+    set names [array names ::dog::snit_ivars]
+    list $result $names [info commands ::dog::spot]
+} -cleanup {
+    dog destroy
+} -result {{No Red Dogs!} {} {}}
+
+test destroy-1.3 {user-defined destructors are called} -body {
+    type dog {
+        typevariable flag ""
+
+        constructor {args} {
+            set flag "created $self"
+        }
+
+        destructor {
+            set flag "destroyed $self"
+        }
+
+        typemethod getflag {} {
+            return $flag
+        }
+    }
+
+    dog create spot
+    set a [dog getflag]
+    spot destroy
+    list $a [dog getflag]
+} -cleanup {
+    dog destroy
+} -result {{created ::spot} {destroyed ::spot}}
+
+test install-1.7 {install works for itcl::types
+} -body {
+    type tail {
+        option -tailcolor black
+    }
+
+    type dog {
+        delegate option -tailcolor to tail
+
+        constructor {args} {
+            installcomponent tail using tail $self.tail
+        }
+    }
+
+    dog fido
+    fido cget -tailcolor
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {black}
+
+#-----------------------------------------------------------------------
+# Setting the widget class explicitly
+
+test widgetclass-1.1 {can't set widgetclass for itcl::types} -body {
+    type dog {
+        widgetclass Dog
+    }
+} -returnCodes {
+    error
+} -result {can't set widgetclass for ::itcl::type}
+
+#-----------------------------------------------------------------------
+# hulltype statement
+
+test hulltype-1.1 {can't set hulltype for snit::types} -body {
+    type dog {
+        hulltype Dog
+    }
+} -returnCodes {
+    error
+} -result {can't set hulltype for ::itcl::type}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/typedelegation.test

@@ -0,0 +1,844 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typefunction.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type proc, method, typemethod commands.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+interp alias {} type {} ::itcl::type
+
+if {1} {
+#-----------------------------------------------------------------------
+# Typemethod delegation
+
+test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
+    set result ""
+
+    type dog {
+        delegate typemethod foo to bar
+    }
+
+    dog foo
+} -returnCodes {
+    error
+} -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}
+
+test dtypemethod-1.2 {delegating to existing typecomponent} -body {
+    type dog {
+        delegate typemethod length to string
+
+        typeconstructor {
+            set string string
+        }
+    }
+
+    dog length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+test dtypemethod-1.4 {delegating to existing typecomponent with error} -body {
+    type dog {
+        delegate typemethod length to string
+
+        typeconstructor {
+            set string string
+        }
+    }
+
+    dog length foo bar
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {wrong # args: should be "dog length string"}
+
+test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
+    type dog {
+        delegate typemethod * to string
+
+        typeconstructor {
+            set string string
+        }
+    }
+
+    dog length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
+    type dog {
+        delegate typemethod * to stringhandler
+
+        typeconstructor {
+            set stringhandler string
+        }
+    }
+
+    dog foo bar
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
+
+test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
+    type dog {
+        typemethod foo {} {}
+        delegate typemethod foo to bar
+    }
+} -returnCodes {
+    error
+} -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}
+
+test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
+    type dog {
+        delegate typemethod foo to bar
+        typemethod foo {} {}
+    }
+} -returnCodes {
+    error
+} -result {Error in "typemethod foo...", "foo" has been delegated}
+
+test dtypemethod-1.10 {excepted methods are caught properly} -body {
+    type dog {
+        delegate typemethod * to string except {match index}
+
+        typeconstructor {
+            set string string
+        }
+    }
+
+    catch {dog length foo} a
+    catch {dog match foo}  b
+    catch {dog index foo}  c
+
+    list $a $b $c
+} -cleanup {
+    dog destroy
+} -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}
+
+test dtypemethod-1.11 {as clause can include arguments} -body {
+    proc tail {a b} {
+        return "<$a $b>"
+    }
+
+    type dog {
+        delegate typemethod wag to tail as {wag briskly}
+
+        typeconstructor {
+            set tail tail
+        }
+    }
+
+    dog wag
+} -cleanup {
+    dog destroy
+    rename tail ""
+} -result {<wag briskly>}
+
+test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
+    type dog {
+        delegate typemethod length to string using {%c %m}
+
+        typeconstructor {
+            set string string
+        }
+    }
+
+    dog length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
+    proc echo {args} {
+        return $args
+    }
+
+    type dog {
+        delegate typemethod tail using {echo %% %t %M %m %j %n %w %s %c}
+    }
+
+    dog tail
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {% ::dog tail tail tail %n %w %s %c}
+
+test dtypemethod-2.3 {"%%" is handled properly} -body {
+    proc echo {args} { join $args "|" }
+
+    type dog {
+        delegate typemethod wag using {echo %%m %%%m}
+    }
+
+    dog wag
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {%m|%wag}
+
+test dtypemethod-2.4 {Method "*" and "using"} -body {
+    proc echo {args} { join $args "|" }
+
+    type dog {
+        delegate typemethod * using {echo %m}
+    }
+
+    list [dog wag] [dog bark loudly]
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {wag bark|loudly}
+
+test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
+    proc echo {args} { join $args "|" }
+
+    type dog {
+        delegate typemethod length to mycomp
+
+        typeconstructor {
+            set mycomp string
+        }
+
+        typemethod switchit {} {
+            set mycomp echo
+        }
+    }
+
+    set a [dog length foo]
+    dog switchit
+    set b [dog length foo]
+
+    list $a $b
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {3 length|foo}
+
+test dtypemethod-4.4 {redefinition is OK} -body {
+    type wag {
+        method tail    {} {return "wags tail"}
+        method briskly {} {return "wags tail briskly"}
+    }
+
+    type dog {
+        typeconstructor {
+            set wag [wag #auto]
+        }
+        delegate typemethod tail to wag as tail
+        delegate typemethod tail to wag as briskly
+    }
+
+    dog tail
+} -cleanup {
+    dog destroy
+    wag destroy
+} -result {wags tail briskly}
+
+#-----------------------------------------------------------------------
+# delegate: general syntax tests
+
+test delegate-1.1 {can only delegate methods or options} -body {
+    type dog {
+        delegate foo bar to baz
+    }
+} -returnCodes {
+    error
+} -result {bad option "foo": should be one of...
+  delegate method name to targetName as scipt using script
+  delegate option option to targetOption as script
+  delegate typemethod name to targetName as scipt using script}
+
+test delegate-1.2 {"to" must appear in the right place} -body {
+    type dog {
+        delegate method foo from bar
+    }
+} -returnCodes {
+    error
+} -result {bad option "from" should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+test delegate-1.3 {"as" must have a target} -body {
+    type dog {
+        delegate method foo to bar as
+    }
+} -returnCodes {
+    error
+} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+test delegate-1.4 {"as" must have a single target} -body {
+    type dog {
+        delegate method foo to bar as baz quux
+    }
+} -returnCodes {
+    error
+} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+test delegate-1.5 {"as" doesn't work with "*"} -body {
+    type dog {
+        delegate method * to hull as foo
+    }
+} -returnCodes {
+    error
+} -result {cannot specify "as" with "delegate method *"}
+
+test delegate-1.6 {"except" must have a target} -body {
+    type dog {
+        delegate method * to bar except
+    }
+} -returnCodes {
+    error
+} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+test delegate-1.7 {"except" must have a single target} -body {
+    type dog {
+        delegate method * to bar except baz quux
+    }
+} -returnCodes {
+    error
+} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+test delegate-1.8 {"except" works only with "*"} -body {
+    type dog {
+        delegate method foo to hull except bar
+    }
+} -returnCodes {
+    error
+} -result {can only specify "except" with "delegate method *"}
+
+test delegate-1.9 {only "as" or "except"} -body {
+    type dog {
+        delegate method foo to bar with quux
+    }
+} -returnCodes {
+    error
+} -result {bad option "with" should be delegate method <methodName> to <componentName> ?as <targetName>?
+delegate method <methodName> ?to <componentName>? using <pattern>
+delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
+
+#-----------------------------------------------------------------------
+# delegated methods
+
+test dmethod-1.1 {delegate method to non-existent component} -body {
+    type dog {
+        delegate method foo to bar
+    }
+
+    dog create spot
+    spot foo
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {::dog ::spot delegates method "foo" to undefined component "bar"}
+
+test dmethod-1.2 {delegating to existing component} -body {
+    type dog {
+        constructor {args} {
+            set string string
+        }
+
+        delegate method length to string
+    }
+
+    dog create spot
+    spot length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+test dmethod-1.4 {delegating to existing component with error} -body {
+    type dog {
+        constructor {args} {
+            set string string
+        }
+
+        delegate method length to string
+    }
+
+    dog create spot
+    spot length foo bar
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {wrong # args: should be "spot length string"}
+
+test dmethod-1.5 {delegating unknown methods to existing component} -body {
+    type dog {
+        constructor {args} {
+            set string string
+        }
+
+        delegate method * to string
+    }
+
+    dog create spot
+    spot length foo
+} -cleanup {
+    dog destroy
+} -result {3}
+
+test dmethod-1.6a {delegating unknown method to existing component with error} -body {
+    type dog {
+        constructor {args} {
+            set stringhandler string
+        }
+
+        delegate method * to stringhandler
+    }
+
+    dog create spot
+    spot foo bar
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
+
+test dmethod-1.7 {can't delegate local method: order 1} -body {
+    type cat {
+        method foo {} {}
+        delegate method foo to hull
+    }
+} -returnCodes {
+    error
+} -result {method "foo" has been defined locally}
+
+test dmethod-1.8 {can't delegate local method: order 2} -body {
+    type cat {
+        delegate method foo to hull
+        method foo {} {}
+    }
+} -returnCodes {
+    error
+} -result {method "foo" has been delegated}
+
+test dmethod-1.10 {excepted methods are caught properly} -body {
+    type tail {
+        method wag {}    {return "wagged"}
+        method flaunt {} {return "flaunted"}
+        method tuck {}   {return "tuck"}
+    }
+
+    type cat {
+        method meow {} {}
+        delegate method * to tail except {wag tuck}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    catch {fifi flaunt} a
+    catch {fifi wag}    b
+    catch {fifi tuck}   c
+
+    list $a $b $c
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}
+
+test dmethod-1.11 {as clause can include arguments} -body {
+    type tail {
+        method wag {adverb}    {return "wagged $adverb"}
+    }
+
+    type dog {
+        delegate method wag to tail as {wag briskly}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    dog spot
+
+    spot wag
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {wagged briskly}
+
+test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
+    type tail {
+        method wag {adverb}    {return "wagged $adverb"}
+    }
+
+    type dog {
+        delegate method wag to tail using {%c %m}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    dog spot
+
+    spot wag briskly
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {wagged briskly}
+
+test dmethod-2.3 {"%%" is handled properly} -body {
+    proc echo {args} { join $args "|" }
+
+    type dog {
+        delegate method wag using {echo %%m %%%m}
+    }
+
+    dog spot
+
+    spot wag
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {%m|%wag}
+
+test dmethod-2.4 {Method "*" and "using"} -body {
+    proc echo {args} { join $args "|" }
+
+    type dog {
+        delegate method * using {echo %m}
+    }
+
+    dog spot
+
+    list [spot wag] [spot bark loudly]
+} -cleanup {
+    dog destroy
+    rename echo ""
+} -result {wag bark|loudly}
+
+test dmethod-3.1 {component names can be changed dynamically} -body {
+    type tail1 {
+        method wag {}    {return "wagged"}
+    }
+
+    type tail2 {
+        method wag {}    {return "drooped"}
+    }
+
+    type dog {
+        delegate method wag to tail
+
+        constructor {args} {
+            set tail [tail1 #auto]
+        }
+
+        method switchit {} {
+            set tail [tail2 #auto]
+        }
+    }
+
+    dog fido
+
+    set a [fido wag]
+    fido switchit
+    set b [fido wag]
+
+    list $a $b
+} -cleanup {
+    dog destroy
+    tail1 destroy
+    tail2 destroy
+} -result {wagged drooped}
+
+#-----------------------------------------------------------------------
+# delegated options
+
+test doption-1.1 {delegate option to non-existent component} -body {
+    type dog {
+        delegate option -foo to bar
+    }
+
+    dog create spot
+    spot cget -foo
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {component "bar" is undefined, needed for option "-foo"}
+
+test doption-1.2 {delegating option to existing component: cget} -body {
+    type cat {
+        option -color "black"
+    }
+
+    cat create hershey
+
+    type dog {
+        constructor {args} {
+            set catthing ::hershey
+        }
+
+        delegate option -color to catthing
+    }
+
+    dog create spot
+    spot cget -color
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {black}
+
+test doption-1.3 {delegating option to existing component: configure} -body {
+    type cat {
+        option -color "black"
+    }
+
+    cat create hershey
+
+    type dog {
+        constructor {args} {
+            set catthing ::hershey
+            $self configure {*}$args
+        }
+
+        delegate option -color to catthing
+    }
+
+    dog create spot -color blue
+    list [spot cget -color] [hershey cget -color]
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {blue blue}
+
+test doption-1.4 {delegating unknown options to existing component} -body {
+    type cat {
+        option -color "black"
+    }
+
+    cat create hershey
+
+    type dog {
+        constructor {args} {
+            set catthing ::hershey
+
+            # Note: must do this after components are defined; this
+            # may be a problem.
+            $self configure {*}$args
+        }
+
+        delegate option * to catthing
+    }
+
+    dog create spot -color blue
+    list [spot cget -color] [hershey cget -color]
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {blue blue}
+
+test doption-1.7 {delegating unknown options to existing component: error} -body {
+    type cat {
+        option -color "black"
+    }
+
+    cat create hershey
+
+    type dog {
+        constructor {args} {
+            set catthing ::hershey
+            $self configure {*}$args
+        }
+
+        delegate option * to catthing
+    }
+
+    dog create spot -colour blue
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {unknown option "-colour"}
+
+test doption-1.8 {can't delegate local option: order 1} -body {
+    type cat {
+        option -color "black"
+        delegate option -color to hull
+    }
+} -returnCodes {
+    error
+} -result {option "-color" has been defined locally}
+
+test doption-1.9 {can't delegate local option: order 2} -body {
+    type cat {
+        delegate option -color to hull
+        option -color "black"
+    }
+} -returnCodes {
+    error
+} -result {cannot define option "-color" locally, it has already been delegated}
+
+test doption-1.10 {excepted options are caught properly on cget} -body {
+    type tail {
+        option -a a
+        option -b b
+        option -c c
+    }
+
+    type cat {
+        delegate option * to tail except {-b -c}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    catch {fifi cget -a} a
+    catch {fifi cget -b} b
+    catch {fifi cget -c} c
+
+    list $a $b $c
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {a {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.11 {excepted options are caught properly on configurelist} -body {
+    type tail {
+        option -a a
+        option -b b
+        option -c c
+    }
+
+    type cat {
+        delegate option * to tail except {-b -c}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    catch {fifi configure {*}{-a 1}} a
+    catch {fifi configure {*}{-b 1}} b
+    catch {fifi configure {*}{-c 1}} c
+
+    list $a $b $c
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {{} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.12 {excepted options are caught properly on configure, 1} -body {
+    type tail {
+        option -a a
+        option -b b
+        option -c c
+    }
+
+    type cat {
+        delegate option * to tail except {-b -c}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    catch {fifi configure -a 1} a
+    catch {fifi configure -b 1} b
+    catch {fifi configure -c 1} c
+
+    list $a $b $c
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {{} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.13 {excepted options are caught properly on configure, 2} -body {
+    type tail {
+        option -a a
+        option -b b
+        option -c c
+    }
+
+    type cat {
+        delegate option * to tail except {-b -c}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    catch {fifi configure -a} a
+    catch {fifi configure -b} b
+    catch {fifi configure -c} c
+
+    list $a $b $c
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.14 {configure query skips excepted options} -body {
+    type tail {
+        option -a a
+        option -b b
+        option -c c
+    }
+
+    type cat {
+        option -d d
+        delegate option * to tail except {-b -c}
+
+        constructor {args} {
+            set tail [tail #auto]
+        }
+    }
+
+    cat fifi
+
+    fifi configure
+} -cleanup {
+    cat destroy
+    tail destroy
+} -result {{-d d D d d} {-a a A a a}}
+
+# end
+}
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/typefunction.test

@@ -0,0 +1,356 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typefunction.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type proc, method, typemethod commands.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+interp alias {} type {} ::itcl::type
+
+#-----------------------------------------------------------------------
+# procs
+
+test proc-1.1 {proc args can span multiple lines} -body {
+    # This case caused an error at definition time in 0.9 because the
+    # arguments were included in a comment in the compile script, and
+    # the subsequent lines weren't commented.
+    type dog {
+        proc foo {
+            a
+            b
+        } { }
+    }
+} -cleanup {
+    dog destroy
+} -result {::dog}
+
+#-----------------------------------------------------------------------
+# methods
+
+test method-1.1 {methods get called} -body {
+    type dog {
+        method bark {} {
+            return "$self barks"
+        }
+    }
+
+    dog create spot
+    spot bark
+} -cleanup {
+    dog destroy
+} -result {::spot barks}
+
+test method-1.2 {methods can call other methods} -body {
+    type dog {
+        method bark {} {
+            return "$self barks."
+        }
+
+        method chase {quarry} {
+            return "$self chases $quarry; [$self bark]"
+        }
+    }
+
+    dog create spot
+    spot chase cat
+} -cleanup {
+    dog destroy
+} -result {::spot chases cat; ::spot barks.}
+
+test method-1.3 {instances can call one another} -body {
+    type dog {
+        method bark {} {
+            return "$self barks."
+        }
+
+        method chase {quarry} {
+            return "$self chases $quarry; [$quarry bark] [$self bark]"
+        }
+    }
+
+    dog create spot
+    dog create fido
+    spot chase ::fido
+} -cleanup {
+    dog destroy
+} -result {::spot chases ::fido; ::fido barks. ::spot barks.}
+
+test method-1.4 {upvar works in methods} -body {
+    type dog {
+        method goodname {varname} {
+            upvar $varname myvar
+            set myvar spot
+        }
+    }
+
+    dog create fido
+    set thename fido
+    fido goodname thename
+    set thename
+} -cleanup {
+    dog destroy
+} -result {spot}
+
+test method-1.6 {unknown methods get an error } -body {
+    type dog { }
+
+    dog create spot
+    set result ""
+    spot chase
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {bad option "chase": should be one of...
+  spot callinstance <instancename>
+  spot cget -option
+  spot configure ?-option? ?value -option value...?
+  spot destroy
+  spot getinstancevar <instancename>
+  spot isa className
+  spot mymethod
+  spot myvar
+  spot unknown}
+
+test method-1.7 {info type method returns the object's type} -body {
+    type dog { }
+
+    dog create spot
+    spot info type
+} -cleanup {
+    dog destroy
+} -result {::dog}
+
+test method-1.8 {instance method can call type method} -body {
+    type dog {
+        typemethod hello {} {
+            return "Hello"
+        }
+        method helloworld {} {
+            return "[$type hello], World!"
+        }
+    }
+
+    dog create spot
+    spot helloworld
+} -cleanup {
+    dog destroy
+} -result {Hello, World!}
+
+test method-1.9 {type methods must be qualified} -body {
+    type dog {
+        typemethod hello {} {
+            return "Hello"
+        }
+        method helloworld {} {
+            return "[hello], World!"
+        }
+    }
+
+    dog create spot
+    spot helloworld
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {invalid command name "hello"}
+
+test method-1.11 {too few arguments} -body {
+    type dog {
+        method bark {volume} { }
+    }
+
+    dog create spot
+    spot bark
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {wrong # args: should be "spot bark volume"}
+
+test method-1.13 {too many arguments} -body {
+    type dog {
+        method bark {volume} { }
+    }
+
+    dog create spot
+
+    spot bark really loud
+} -cleanup {
+    dog destroy
+} -returnCodes {
+    error
+} -result {wrong # args: should be "spot bark volume"}
+
+test method-1.14 {method args can't include type} -body {
+    type dog {
+        method foo {a type b} { }
+    }
+} -returnCodes {
+    error
+} -result {method foo's arglist may not contain "type" explicitly}
+
+test method-1.15 {method args can't include self} -body {
+    type dog {
+        method foo {a self b} { }
+    }
+} -returnCodes {
+    error
+} -result {method foo's arglist may not contain "self" explicitly}
+
+test method-1.16 {method args can span multiple lines} -body {
+    # This case caused an error at definition time in 0.9 because the
+    # arguments were included in a comment in the compile script, and
+    # the subsequent lines weren't commented.
+    type dog {
+        method foo {
+                    a
+                    b
+                } { }
+    }
+} -cleanup {
+    dog destroy
+} -result {::dog}
+
+#-----------------------------------------------------------------------
+# mymethod actually works
+
+test mymethod-1.1 {run mymethod handler} -body {
+    type foo {
+        option -command {}
+        method runcmd {} {
+            eval [linsert $itcl_options(-command) end $self snarf]
+            return
+        }
+    }
+    type bar {
+        variable sub
+        constructor {args} {
+            set sub [foo fubar -command [mymethod Handler]]
+            return
+        }
+
+        method Handler {args} {
+            set ::RES $args
+        }
+
+        method test {} {
+            $sub runcmd
+            return
+        }
+    }
+
+    set ::RES {}
+    bar boogle
+    boogle test
+    set ::RES
+} -cleanup {
+    bar destroy
+    foo destroy
+} -result {::bar::fubar snarf}
+
+#-----------------------------------------------------------------------
+# myproc
+
+test myproc-1.1 {myproc qualifies proc names} -body {
+    type dog {
+        proc foo {} {}
+
+        typemethod getit {} {
+            return [myproc foo]
+        }
+    }
+
+    dog getit
+} -cleanup {
+    dog destroy
+} -result {::dog::foo}
+
+test myproc-1.2 {myproc adds arguments} -body {
+    type dog {
+        proc foo {} {}
+
+        typemethod getit {} {
+            return [myproc foo "a b"]
+        }
+    }
+
+    dog getit
+} -cleanup {
+    dog destroy
+} -result {::dog::foo {a b}}
+
+test myproc-1.3 {myproc adds arguments} -body {
+    type dog {
+        proc foo {} {}
+
+        typemethod getit {} {
+            return [myproc foo "a b" c d]
+        }
+    }
+
+    dog getit
+} -cleanup {
+    dog destroy
+} -result {::dog::foo {a b} c d}
+
+test myproc-1.4 {procs with selfns work} -body {
+    type dog {
+        variable datum foo
+
+        method qualify {} {
+            return [myproc getdatum $selfns]
+        }
+        proc getdatum {selfns} {
+            return [set ${selfns}::datum]
+        }
+    }
+    dog create spot
+    eval [spot qualify]
+} -cleanup {
+    dog destroy
+} -result {foo}
+
+#-----------------------------------------------------------------------
+# mytypemethod
+
+test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
+    type dog {
+        typemethod this {} {}
+
+        typemethod a {} {
+            return [mytypemethod this]
+        }
+        typemethod b {} {
+            return [mytypemethod this x]
+        }
+        typemethod c {} {
+            return [mytypemethod this "x y"]
+        }
+        typemethod d {} {
+            return [mytypemethod this x y]
+        }
+    }
+    list [dog a] [dog b] [dog c] [dog d]
+} -cleanup {
+    dog destroy
+} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/typeoption.test

@@ -0,0 +1,556 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typeoption.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type proc, method, typemethod commands.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+interp alias {} type {} ::itcl::type
+
+#-----------------------------------------------------------------------
+# Options
+
+test option-1.1 {options get default values} -body {
+    type dog {
+        option -color golden
+    }
+
+    dog create spot
+    spot cget -color
+} -cleanup {
+    dog destroy
+} -result {golden}
+
+test option-1.2 {options can be set} -body {
+    type dog {
+        option -color golden
+    }
+
+    dog create spot
+    spot configure -color black
+    spot cget -color
+} -cleanup {
+    dog destroy
+} -result {black}
+
+test option-1.3 {multiple options can be set} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot
+    spot configure -color brown -akc 1
+    list [spot cget -color] [spot cget -akc]
+} -cleanup {
+    dog destroy
+} -result {brown 1}
+
+test option-1.4 {options can be retrieved as instance variable} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+
+        method listopts {} {
+            list $itcl_options(-color) $itcl_options(-akc)
+        }
+    }
+
+    dog create spot
+    spot configure -color black -akc 1
+    spot listopts
+} -cleanup {
+    dog destroy
+} -result {black 1}
+
+test option-1.5 {options can be set as an instance variable} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+
+        method setopts {} {
+            set itcl_options(-color) black
+            set itcl_options(-akc) 1
+        }
+    }
+
+    dog create spot
+    spot setopts
+    list [spot cget -color] [spot cget -akc]
+} -cleanup {
+    dog destroy
+} -result {black 1}
+
+test option-1.6 {options can be set at creation time} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot -color white -akc 1
+    list [spot cget -color] [spot cget -akc]
+} -cleanup {
+    dog destroy
+} -result {white 1}
+
+test option-1.7 {undefined option: cget} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot
+    spot cget -colour
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {unknown option "-colour"}
+
+test option-1.8 {undefined option: configure} -body {
+    type dog {
+        option -color golden
+        option -akc 0
+    }
+
+    dog create spot
+    spot configure -colour blue
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {unknown option "-colour"}
+
+test option-1.9 {options default to ""} -body {
+    type dog {
+        option -color
+    }
+
+
+    dog create spot
+    spot cget -color
+} -cleanup {
+    dog destroy
+} -result {<undefined>}
+
+test option-1.10 {spaces allowed in option defaults} -body {
+    type dog {
+        option -breed "golden retriever"
+    }
+    dog fido
+    fido cget -breed
+} -cleanup {
+    dog destroy
+} -result {golden retriever}
+
+test option-1.11 {brackets allowed in option defaults} -body {
+    type dog {
+        option -regexp {[a-z]+}
+    }
+
+    dog fido
+    fido cget -regexp
+} -cleanup {
+    dog destroy
+} -result {[a-z]+}
+
+test option-2.1 {configure returns info, local options only} -body {
+    type dog {
+        option -color black
+        option -akc 1
+    }
+
+    dog create spot
+    spot configure -color red
+    spot configure -akc 0
+    lsort [spot configure]
+} -cleanup {
+    dog destroy
+} -result {{-akc akc Akc 1 0} {-color color Color black red}}
+
+test option-2.2 {configure -opt returns info, local options only} -body {
+    type dog {
+        option -color black
+        option -akc 1
+    }
+
+    dog create spot
+    spot configure -color red
+    spot configure -color
+} -cleanup {
+    dog destroy
+} -result {-color color Color black red}
+
+test option-2.3 {configure -opt returns info, explicit options} -body {
+    type papers {
+        option -akcflag 1
+    }
+
+    type dog {
+        option -color black
+        delegate option -akc to papers as -akcflag
+        constructor {args} {
+            set papers [papers create $self.papers]
+        }
+
+        destructor {
+            catch {$self.papers destroy}
+        }
+    }
+
+    dog create spot
+    spot configure -akc 0
+    spot configure -akc
+} -cleanup {
+    dog destroy
+    papers destroy
+} -result {-akc akc Akc 1 0}
+
+test option-2.4 {configure -unknownopt} -body {
+    type papers {
+        option -akcflag 1
+    }
+
+    type dog {
+        option -color black
+        delegate option -akc to papers as -akcflag
+        constructor {args} {
+            set papers [papers create $self.papers]
+        }
+
+        destructor {
+            catch {$self.papers destroy}
+        }
+    }
+
+    dog create spot
+    spot configure -foo
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+    papers destroy
+} -result {unknown option "-foo"}
+
+test option-3.1 {set option resource name explicitly} -body {
+    type dog {
+        option {-tailcolor tailColor} black
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+} -result {-tailcolor tailColor TailColor black black}
+
+test option-3.2 {set option class name explicitly} -body {
+    type dog {
+        option {-tailcolor tailcolor TailColor} black
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+} -result {-tailcolor tailcolor TailColor black black}
+
+test option-3.3 {delegated option's names come from owner} -body {
+    type tail {
+        option -color black
+    }
+
+    type dog {
+        delegate option -tailcolor to tail as -color
+
+        constructor {args} {
+            set tail [tail fidotail]
+        }
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {-tailcolor tailcolor Tailcolor black black}
+
+test option-3.4 {delegated option's resource name set explicitly} -body {
+    type tail {
+        option -color black
+    }
+
+    type dog {
+        delegate option {-tailcolor tailColor} to tail as -color
+
+        constructor {args} {
+            set tail [tail fidotail]
+        }
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {-tailcolor tailColor TailColor black black}
+
+test option-3.5 {delegated option's class name set explicitly} -body {
+    type tail {
+        option -color black
+    }
+
+    type dog {
+        delegate option {-tailcolor tailcolor TailColor} to tail as -color
+
+        constructor {args} {
+            set tail [tail fidotail]
+        }
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {-tailcolor tailcolor TailColor black black}
+
+test option-3.6 {delegated option's default comes from component} -body {
+    type tail {
+        option -color black
+    }
+
+    type dog {
+        delegate option -tailcolor to tail as -color
+
+        constructor {args} {
+            set tail [tail fidotail -color red]
+        }
+    }
+
+    dog fido
+
+    fido configure -tailcolor
+} -cleanup {
+    dog destroy
+    tail destroy
+} -result {-tailcolor tailcolor Tailcolor black red}
+
+test option-4.1 {local option name must begin with hyphen} -body {
+    type dog {
+        option nohyphen
+    }
+} -returnCodes {
+    error
+} -result {bad option name "nohyphen", options must start with a "-"}
+
+test option-4.2 {local option name must be lower case} -body {
+    type dog {
+        option -Upper
+    }
+} -returnCodes {
+    error
+} -result {bad option name "-Upper" , options must not contain uppercase characters}
+
+test option-4.3 {local option name may not contain spaces} -body {
+    type dog {
+        option {"-with space"}
+    }
+} -returnCodes {
+    error
+} -result {bad option name "-with space", option names must not contain " "}
+
+test option-4.4 {delegated option name must begin with hyphen} -body {
+    type dog {
+        delegate option nohyphen to tail
+    }
+} -returnCodes {
+    error
+} -result {bad delegated option name "nohyphen", options must start with a "-"}
+
+test option-4.5 {delegated option name must be lower case} -body {
+    type dog {
+        delegate option -Upper to tail
+    }
+} -returnCodes {
+    error
+} -result {bad option name "-Upper" , options must not contain uppercase characters}
+
+test option-4.6 {delegated option name may not contain spaces} -body {
+    type dog {
+        delegate option {"-with space"} to tail
+    }
+} -returnCodes {
+    error
+} -result {bad option name "-with space", option names must not contain " "}
+
+test option-6.1a {itcl_options variable is always there} -body {
+    type dog {
+        variable dummy
+    }
+
+    dog spot
+    spot info vars itcl_options
+} -cleanup {
+    dog destroy
+} -result {itcl_options}
+
+test option-6.2 {if no options, no options methods} -body {
+    type dog {
+        variable dummy
+    }
+
+    dog spot
+    spot info methods c*
+} -cleanup {
+    dog destroy
+} -result {}
+
+#-----------------------------------------------------------------------
+# option -validatemethod
+
+test validatemethod-1.1 {Validate method is called} -body {
+    type dog {
+        variable flag 0
+
+        option -color \
+            -default black \
+            -validatemethod ValidateColor
+
+        method ValidateColor {option value} {
+            set flag 1
+        }
+
+        method getflag {} {
+            return $flag
+        }
+    }
+
+    dog fido -color brown
+    fido getflag
+} -cleanup {
+    dog destroy
+} -result {1}
+
+test validatemethod-1.2 {Validate method gets correct arguments} -body {
+    type dog {
+        option -color \
+            -default black \
+            -validatemethod ValidateColor
+
+        method ValidateColor {option value} {
+            if {![string equal $option "-color"] ||
+                ![string equal $value "brown"]} {
+                error "Expected '-color brown'"
+            }
+        }
+    }
+
+    dog fido -color brown
+} -cleanup {
+    dog destroy
+} -result {::fido}
+
+test validatemethod-1.4 {Invalid -validatemethod causes error} -body {
+    type dog {
+        option -foo -default bar -validatemethod bogus
+    }
+
+    dog fido
+    fido configure -foo quux
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {invalid command name "bogus"}
+
+test validatemethod-1.5 {hierarchical -validatemethod} -body {
+    type dog {
+        option -foo -default bar -validatemethod {Val Opt}
+
+        method {Val Opt} {option value} {
+            error "Dummy"
+        }
+    }
+
+    dog fido -foo value
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {Dummy}
+
+
+
+#-----------------------------------------------------------------------
+# option -readonly semantics
+
+test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
+    type dog {
+        option -color \
+            -default black \
+            -readonly true
+    }
+
+    dog fido -color brown
+
+    fido cget -color
+} -cleanup {
+    dog destroy
+} -result {brown}
+
+test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
+    type dog {
+        option -color \
+            -default black \
+            -readonly true
+    }
+
+    dog fido
+
+    fido configure -color brown
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {option "-color" can only be set at instance creation}
+
+test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
+    type dog {
+        option -color \
+            -default black \
+            -readonly true
+    }
+
+    dog fido -color yellow
+
+    fido configure -color brown
+} -returnCodes {
+    error
+} -cleanup {
+    dog destroy
+} -result {option "-color" can only be set at instance creation}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/typevariable.test

@@ -0,0 +1,335 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typefunction.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type proc, method, typemethod commands.
+#       Uses the ::tcltest:: harness.
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+package require itcl
+
+interp alias {} type {} ::itcl::type
+
+#-----------------------------------------------------------------------
+# Type variables
+
+test typevariable-1.2 {undefined typevariables are OK} -body {
+    type dog {
+        typevariable theValue
+        method tset {value} {
+            set theValue $value
+        }
+
+        method tget {} {
+            return $theValue
+        }
+    }
+
+    dog create spot
+    dog create fido
+    spot tset Howdy
+
+    list [spot tget] [fido tget] [set ::dog::theValue]
+} -cleanup {
+    dog destroy
+} -result {Howdy Howdy Howdy}
+
+test typevariable-1.3 {predefined typevariables are OK} -body {
+    type dog {
+        typevariable greeting Hello
+
+        method tget {} {
+            return $greeting
+        }
+    }
+
+    dog create spot
+    dog create fido
+
+    list [spot tget] [fido tget] ;# FIXME [set ::dog::greeting]
+} -cleanup {
+    dog destroy
+} -result {Hello Hello}
+
+test typevariable-1.4 {typevariables can be arrays} -body {
+    type dog {
+        typevariable greetings
+
+        method fill {} {
+            set greetings(a) Hi
+            set greetings(b) Howdy
+        }
+    }
+
+    dog create spot
+    spot fill
+    list $::dog::greetings(a) $::dog::greetings(b)
+} -cleanup {
+    dog destroy
+} -result {Hi Howdy}
+
+test typevariable-1.5 {typevariables can used in typemethods} -body {
+    type dog {
+        typevariable greetings Howdy
+
+        typemethod greet {} {
+            return $greetings
+        }
+    }
+
+    dog greet
+} -cleanup {
+    dog destroy
+} -result {Howdy}
+
+test typevariable-1.6 {typevariables can used in procs} -body {
+    type dog {
+        typevariable greetings Howdy
+
+        method greet {} {
+            return [realGreet]
+        }
+
+        proc realGreet {} {
+            return $greetings
+        }
+    }
+
+    dog create spot
+    spot greet
+} -cleanup {
+    dog destroy
+} -result {Howdy}
+
+test typevariable-1.7 {mytypevar qualifies typevariables} -body {
+    type dog {
+        method tvname {name} {
+            mytypevar $name
+        }
+    }
+
+    dog create spot
+    spot tvname myvar
+} -cleanup {
+    dog destroy
+} -result {::dog::myvar}
+
+test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
+    type dog {
+        typevariable color dark brown
+    }
+} -returnCodes {
+    error
+} -result {wrong # args: should be "typevariable varname ?init?"}
+
+test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
+    type dog {
+        typevariable color -array dark brown
+    }
+
+    set result
+} -returnCodes {
+    error
+} -result {wrong # args: should be "typevariable varname ?init|-array init?"}
+
+test typevariable-1.10 {typevariable can initialize array variables} -body {
+    type dog {
+        typevariable data -array {
+            family jones
+            color brown
+        }
+
+        typemethod getdata {item} {
+            return $data($item)
+        }
+    }
+
+    list [dog getdata family] [dog getdata color]
+} -cleanup {
+    dog destroy
+} -result {jones brown}
+
+#-----------------------------------------------------------------------
+# instance variable
+
+test ivariable-1.1 {myvar qualifies instance variables} -body {
+    type dog {
+        method vname {name} {
+            myvar $name
+        }
+    }
+
+    dog create spot
+    spot vname somevar
+} -cleanup {
+    dog destroy
+} -match glob -result {::itcl::internal::variables::*::dog::somevar}
+
+test ivariable-1.2 {undefined instance variables are OK} -body {
+    type dog {
+        variable greeting
+        method setgreeting {value} {
+            set greeting $value
+        }
+
+        method getgreeting {} {
+            return $greeting
+        }
+    }
+
+    set spot [dog create spot]
+    spot setgreeting Hey
+
+    dog create fido
+    fido setgreeting Howdy
+
+    list [spot getgreeting] [fido getgreeting] [set ::itcl::internal::variables[info object namespace spot]::dog::greeting]
+} -cleanup {
+    dog destroy
+} -result {Hey Howdy Hey}
+
+test ivariable-1.3 {instance variables are destroyed automatically} -body {
+    type dog {
+        variable greeting
+        constructor {args} {
+            set greeting Hi
+        }
+    }
+
+    dog create spot
+    set ns [info object namespace spot]
+    set g1 [set ::itcl::internal::variables${ns}::dog::greeting]
+
+    spot destroy
+    list $g1 [info exists ::itcl::internal::variables${ns}::dog::greeting]
+} -cleanup {
+    dog destroy
+} -result {Hi 0}
+
+test ivariable-1.4 {defined instance variables need not be declared} -body {
+    type dog {
+        variable greetings
+
+        method put {} {
+            set greetings Howdy
+        }
+
+        method get {} {
+            return $greetings
+        }
+    }
+
+    dog create spot
+    spot put
+    spot get
+} -cleanup {
+    dog destroy
+} -result {Howdy}
+
+test ivariable-1.5 {instance variables can be arrays} -body {
+    type dog {
+        variable greetings
+
+        method fill {} {
+            set greetings(a) Hi
+            set greetings(b) Howdy
+        }
+
+        method vname {} {
+            return [myvar greetings]
+        }
+    }
+
+    dog create spot
+    spot fill
+    list [set [spot vname](a)] [set [spot vname](b)]
+} -cleanup {
+    dog destroy
+} -result {Hi Howdy}
+
+test ivariable-1.6 {instance variables can be initialized in the definition} -body {
+    type dog {
+        variable greetings {Hi Howdy}
+        variable empty {}
+
+        method list {} {
+            list $greetings $empty
+        }
+    }
+
+    dog create spot
+    spot list
+} -cleanup {
+    dog destroy
+} -result {{Hi Howdy} {}}
+
+test ivariable-1.9 {procs which define selfns see instance variables} -body {
+    type dog {
+        variable greeting Howdy
+
+        method caller {} {
+            return [callee $selfns]
+        }
+
+        proc callee {selfns} {
+            return [set ${selfns}::greeting]
+        }
+    }
+
+    dog create spot
+
+    spot caller
+} -cleanup {
+    dog destroy
+} -result {Howdy}
+
+test ivariable-1.11 {variable with too many initializers throws an error} -body {
+    type dog {
+        variable color dark brown
+    }
+} -returnCodes {
+    error
+} -result {wrong # args: should be "variable name ?init?"}
+
+test ivariable-1.12 {variable with too many initializers throws an error} -body {
+    type dog {
+        variable color -array dark brown
+    }
+} -returnCodes {
+    error
+} -result {wrong # args: should be "variable varname ?init|-array init?"}
+
+test ivariable-1.13 {variable can initialize array variables} -body {
+    type dog {
+        variable data -array {
+            family jones
+            color brown
+        }
+
+        method getdata {item} {
+            return $data($item)
+        }
+    }
+
+    dog spot
+    list [spot getdata family] [spot getdata color]
+} -cleanup {
+    dog destroy
+} -result {jones brown}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+cleanupTests
+return

pkgs/itcl4.2.2/tests/widgetadaptor.test

@@ -0,0 +1,825 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       typefunction.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type proc, method, typemethod commands.
+#       Uses the ::tcltest:: harness.
+#
+#       There is at least Tcl 8.6a3 needed
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Declare the minimal version of Tcl required to run the package
+## tested by this testsuite, and its dependencies.
+
+proc testsNeedTcl {version} {
+    # This command ensures that a minimum version of Tcl is used to
+    # run the tests in the calling testsuite. If the minimum is not
+    # met by the active interpreter we forcibly bail out of the
+    # testsuite calling the command. The command has to be called
+    # immediately after loading the utilities.
+
+    if {[package vsatisfies [package provide Tcl] ${version}-]} return
+
+    puts "    Aborting the tests found in \"[file tail [info script]]\""
+    puts "    Requiring at least Tcl $version, have [package provide Tcl]."
+
+    # This causes a 'return' in the calling scope.
+    return -code return
+}
+
+# ### ### ### ######### ######### #########
+## Declare the minimum version of Tcltest required to run the
+## testsuite.
+
+proc testsNeedTcltest {version} {
+    # This command ensure that a minimum version of the Tcltest
+    # support package is used to run the tests in the calling
+    # testsuite. If the minimum is not met by the loaded package we
+    # forcibly bail out of the testsuite calling the command. The
+    # command has to be called after loading the utilities. The only
+    # command allowed to come before it is 'textNeedTcl' above.
+
+    # Note that this command will try to load a suitable version of
+    # Tcltest if the package has not been loaded yet.
+
+    if {[lsearch [namespace children] ::tcltest] == -1} {
+	if {![catch {
+	    package require tcltest $version
+	}]} {
+	    namespace import -force ::tcltest::*
+	    return
+	}
+    } elseif {[package vcompare [package present tcltest] $version] >= 0} {
+	namespace import -force ::tcltest::*
+	return
+    }
+
+    puts "    Aborting the tests found in [file tail [info script]]."
+    puts "    Requiring at least tcltest $version, have [package present tcltest]"
+
+    # This causes a 'return' in the calling scope.
+    return -code return
+}
+
+# Set up for Tk tests: enter the event loop long enough to catch
+# any bgerrors.
+proc tkbide {{msg "tkbide"} {msec 500}} {
+    set ::bideVar 0
+    set ::bideError ""
+    set ::bideErrorInfo ""
+    # It looks like update idletasks does the job.
+    if {0} {
+        after $msec {set ::bideVar 1}
+        tkwait variable ::bideVar
+    }
+    update idletasks
+    if {"" != $::bideError} {
+        error "$msg: $::bideError" $::bideErrorInfo
+    }
+}
+
+testsNeedTcl     8.6
+testsNeedTcltest 2.2
+
+interp alias {} type {} ::itcl::type
+interp alias {} widgetadaptor {} ::itcl::widgetadaptor
+
+# Marks tests which are only for Tk.
+tcltest::testConstraint tk [expr {![catch {package require Tk}]}]
+
+::tcltest::loadTestedCommands
+package require itcl
+
+#-----------------------------------------------------------------------
+# Widgetadaptors
+
+test widgetadaptor-1.1 {creating a widget: hull hijacking
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+            $self configure {*}$args
+        }
+
+        delegate method * to itcl_hull
+        delegate option * to itcl_hull
+    }
+
+    set xx [mylabel create .label -text "My Label"]
+
+    set a [.label cget -text]
+    set b [::itcl::internal::widgets::hull1.label cget -text]
+
+    destroy .label
+    tkbide
+    list $a $b
+} -cleanup {
+    mylabel destroy
+} -result {{My Label} {My Label}}
+
+test widgetadaptor-1.2 {destroying a widget with destroy
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .label
+    set a [lsort [namespace children ::itcl::internal::variables]]
+    destroy .label
+    set b [lsort [namespace children ::itcl::internal::variables]]
+    tkbide
+    list $a $b
+} -cleanup {
+    mylabel destroy
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.3 {destroying two widgets of the same type with destroy
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .lab1
+    mylabel create .lab2
+    set a [lsort [namespace children ::itcl::internal::variables]]
+    destroy .lab1
+    destroy .lab2
+    set b [lsort [namespace children ::itcl::internal::variables]]
+    tkbide
+    list $a $b
+} -cleanup {
+    mylabel destroy
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.4 {destroying a widget with rename, then destroy type
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .label
+    set a [lsort [namespace children ::itcl::internal::variables]]
+    rename .label ""
+    set b [lsort [namespace children ::itcl::internal::variables]]
+
+    mylabel destroy
+    tkbide
+    list $a $b
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.5 {destroying two widgets of the same type with rename
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .lab1
+    mylabel create .lab2
+    set a [lsort [namespace children ::itcl::internal::variables]]
+    rename .lab1 ""
+    rename .lab2 ""
+    set b [lsort [namespace children ::itcl::internal::variables]]
+    mylabel destroy
+    tkbide
+    list $a $b
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.6 {create/destroy twice, with destroy
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .lab1
+    set a [namespace children ::itcl::internal::variables]
+    destroy .lab1
+
+    mylabel create .lab1
+    set b [namespace children ::itcl::internal::variables]
+    destroy .lab1
+
+    set c [namespace children ::itcl::internal::variables]
+    mylabel destroy
+    tkbide
+    list $a $b $c
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.7 {create/destroy twice, with rename
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel create .lab1
+    set a [namespace children ::itcl::internal::variables]
+    rename .lab1 ""
+
+    mylabel create .lab1
+    set b [namespace children ::itcl::internal::variables]
+    rename .lab1 ""
+
+    set c [namespace children ::itcl::internal::variables]
+    mylabel destroy
+    tkbide
+    list $a $b $c
+} -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.8 {"create" is optional
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+        }
+        method howdy {} {return "Howdy!"}
+    }
+
+    mylabel .label
+    set a [.label howdy]
+
+    destroy .label
+    tkbide
+    set a
+} -cleanup {
+    mylabel destroy
+} -result {Howdy!}
+
+test widgetadaptor-1.10 {"create" is optional, but must be a valid name
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+        }
+        method howdy {} {return "Howdy!"}
+    }
+
+    catch {mylabel foo} result
+    tkbide
+    set result
+} -cleanup {
+    mylabel destroy
+} -result {bad window path name "foo"}
+
+test widgetadaptor-1.11 {user-defined destructors are called
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        typevariable flag ""
+
+        constructor {args} {
+            installhull [label $self]
+            set flag "created $self"
+        }
+
+        destructor {
+            set flag "destroyed $self"
+        }
+
+        typemethod getflag {} {
+            return $flag
+        }
+    }
+
+    mylabel .label
+    set a [mylabel getflag]
+    destroy .label
+    tkbide
+    list $a [mylabel getflag]
+} -cleanup {
+    mylabel destroy
+} -result {{created ::itcl::internal::widgets::hull1.label} {destroyed ::itcl::internal::widgets::hull1.label}}
+
+test widgetadaptor-1.12 {Constructor errors tolerated
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {error foo}
+        destructor {}
+    }
+
+    # Without bug fix this will crash
+    mylabel .label
+} -cleanup {
+    mylabel destroy
+} -returnCodes error -result foo
+
+test widgetadaptor-1.14 {hull can be repeatedly renamed
+} -constraints {
+    tk
+} -body {
+    widgetadaptor basetype {
+        constructor {args} {
+            installhull [label $self]
+        }
+
+        method basemethod {} { return "basemethod" }
+    }
+
+    widgetadaptor w1 {
+        constructor {args} {
+            installhull [basetype create $self]
+        }
+    }
+
+    widgetadaptor w2 {
+        constructor {args} {
+            installhull [w1 $self]
+        }
+    }
+
+    set a [w2 .foo]
+    destroy .foo
+    tkbide
+    set a
+} -cleanup {
+    w2 destroy
+    w1 destroy
+    basetype destroy
+} -result {.foo}
+
+test widgetadaptor-1.15 {widget names can be generated
+} -constraints {
+    tk
+} -body {
+    widgetadaptor unique {
+        constructor {args} {
+            installhull [label $self]
+        }
+    }
+
+    set w [unique .#auto]
+    destroy $w
+    tkbide
+    set w
+} -cleanup {
+    unique destroy
+} -result {.unique0}
+
+test widgetadaptor-1.16 {snit::widgetadaptor as hull
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+	    if {[llength $args]} {
+                $self configure {*}$args
+	    }
+        }
+        method method1 {} {
+            return "method1"
+        }
+        delegate option * to itcl_hull
+    }
+
+    widgetadaptor mylabel2 {
+        constructor {args} {
+            installhull [mylabel $self]
+                $self configure {*}$args
+        }
+        method method2 {} {
+            return "method2: [$itcl_hull method1]"
+        }
+        delegate option * to itcl_hull
+    }
+
+    mylabel2 .label -text "Some Text"
+    set a [.label method2]
+    set b [.label cget -text]
+    .label configure -text "More Text"
+    set c [.label cget -text]
+    set d [lsort [namespace children ::itcl::internal::variables]]
+
+    destroy .label
+
+    set e [lsort [namespace children ::itcl::internal::variables]]
+
+    mylabel2 destroy
+    mylabel destroy
+
+    tkbide
+    list $a $b $c $d $e
+} -result {{method2: method1} {Some Text} {More Text} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+            $self configure {*}$args
+        }
+        method method1 {} {
+            return "method1"
+        }
+        delegate option * to itcl_hull
+    }
+
+    widgetadaptor mylabel2 {
+        constructor {args} {
+            installhull [mylabel $self]
+            $self configure {*}$args
+        }
+        method method2 {} {
+            return "method2: [$itcl_hull method1]"
+        }
+        delegate option * to itcl_hull
+    }
+
+    mylabel2 .label -text "Some Text"
+    set a [.label method2]
+    set b [.label cget -text]
+    .label configure -text "More Text"
+    set c [.label cget -text]
+    set d [lsort [namespace children ::itcl::internal::variables]]
+
+    rename .label ""
+
+    set e [lsort [namespace children ::itcl::internal::variables]]
+
+    mylabel2 destroy
+    mylabel destroy
+
+    tkbide
+    list $a $b $c $d $e
+} -result {{method2: method1} {Some Text} {More Text} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo}}
+
+test widgetadaptor-1.19 {error in widgetadaptor constructor
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            error "Simulated Error"
+        }
+    }
+
+    mylabel .lab
+} -returnCodes {
+    error
+} -cleanup {
+    mylabel destroy
+} -result {Simulated Error}
+
+
+test install-1.3 {can't install until hull exists
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        # Delegate an option just to make sure the component variable
+        # exists.
+        delegate option -font to text
+
+        constructor {args} {
+            installcomponent text using text $win.text -background green
+        }
+    }
+
+    myframe .frm
+} -returnCodes {
+    error
+} -cleanup {
+    myframe destroy
+} -result {cannot install "text" before "itcl_hull" exists}
+
+test installhull-1.3 {
+    options delegated to a widgetadaptor's itcl_hull frame
+    with the same name are
+    initialized from the option database.  Note that there's no
+    explicit code in Snit to do this; there's no way to change the
+    adapted hull widget's -class, so the widget is simply being
+    initialized normally.
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        delegate option -background to itcl_hull
+
+        typeconstructor {
+            option add *Frame.background red
+            option add *Frame.width 123
+        }
+
+        constructor {args} {
+            installhull using frame
+        }
+
+        method getwid {} {
+            $itcl_hull cget -width
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -background]
+    set b [.frm getwid]
+    destroy .frm
+    tkbide
+    list $a $b
+} -cleanup {
+    myframe destroy
+} -result {red 123}
+
+test installhull-1.4 {
+    Options delegated to a widget's itcl_hull frame with a different name are
+    initialized from the option database.
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        delegate option -mainbackground to itcl_hull as -background
+
+        typeconstructor {
+            option add *Frame.mainbackground red
+        }
+
+        constructor {args} {
+            installhull using frame
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -mainbackground]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {red}
+
+test installhull-1.5 {
+    Option values read from the option database are overridden by options
+    explicitly passed, even if delegated under a different name.
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        delegate option -mainbackground to itcl_hull as -background
+
+        typeconstructor {
+            option add *Frame.mainbackground red
+            option add *Frame.width 123
+        }
+
+        constructor {args} {
+            installhull using frame -background green -width 321
+        }
+
+        method getwid {} {
+            $itcl_hull cget -width
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -mainbackground]
+    set b [.frm getwid]
+    destroy .frm
+    tkbide
+    list $a $b
+} -cleanup {
+    myframe destroy
+} -result {green 321}
+
+test option-2.5 {configure returns info, unknown options
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        option -foo a
+        delegate option -width to itcl_hull
+        delegate option * to itcl_hull
+        constructor {args} {
+	    # need to reset because of test installhull-1.5
+            option add *Frame.width 0
+            installhull [frame $self]
+        }
+    }
+
+    myframe .frm
+    set a [.frm configure -foo]
+    set b [.frm configure -width]
+    set c [.frm configure -height]
+    destroy .frm
+    tkbide
+
+    list $a $b $c
+
+} -cleanup {
+    myframe destroy
+} -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}}
+
+test option-2.6 {configure -opt unknown to implicit component
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        delegate option * to itcl_hull
+        constructor {args} {
+            installhull [frame $self]
+        }
+    }
+    myframe .frm
+    catch {.frm configure -quux} result
+    destroy .frm
+    tkbide
+    set result
+} -cleanup {
+    myframe destroy
+} -result {unknown option "-quux"}
+
+test iinfo-6.5 {info options with unknown delegated options
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        option -foo a
+        delegate option * to itcl_hull
+        constructor {args} {
+            installhull [frame $self]
+        }
+    }
+    myframe .frm
+
+    set a [lsort [.frm info options]]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
+
+test iinfo-6.7 {info options with exceptions
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        option -foo a
+        delegate option * to itcl_hull except -background
+        constructor {args} {
+            installhull [frame $self]
+        }
+    }
+    myframe .frm
+
+    set a [lsort [.frm info options]]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
+
+test iinfo-6.8 {info options with pattern
+} -constraints {
+    tk
+} -body {
+    widgetadaptor myframe {
+        option -foo a
+        delegate option * to itcl_hull
+        constructor {args} {
+            installhull [frame $self]
+        }
+    }
+    myframe .frm
+
+    set a [lsort [.frm info options -c*]]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {-class -colormap -container -cursor}
+
+test tinfo-3.2 {widget info instances
+} -constraints {
+    tk
+} -body {
+    widgetadaptor mylabel {
+        constructor {args} {
+            installhull [label $self]
+        }
+    }
+
+    mylabel .lab1
+    mylabel .lab2
+
+    set result [mylabel info instances]
+
+    destroy .lab1
+    destroy .lab2
+    tkbide
+
+    lsort $result
+} -cleanup {
+    mylabel destroy
+} -result {.lab1 .lab2}
+
+test widgetclass-1.2 {can't set widgetclass for itcl::widgetadaptors
+} -constraints {
+    tk
+} -body {
+    widgetadaptor dog {
+        widgetclass Dog
+    }
+} -returnCodes {
+    error
+} -result {can't set widgetclass for ::itcl::widgetadaptor}
+
+test hulltype-1.2 {can't set hulltype for itcl::widgetadaptors
+} -constraints {
+    tk
+} -body {
+    widgetadaptor dog {
+        hulltype Dog
+    }
+} -returnCodes {
+    error
+} -result {can't set hulltype for ::itcl::widgetadaptor}
+
+test wainfo-10.1 {widgetadaptor info widgetadaptors
+} -constraints {
+    tk
+} -body {
+    widgetadaptor dog {
+    }
+
+    widgetadaptor cat {
+    }
+
+    lsort [dog info widgetadaptors]
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {cat dog}
+
+test wainfo-10.2 {widgetadaptor info components
+} -constraints {
+    tk
+} -body {
+    widgetadaptor dog {
+        component comp1
+        component comp2
+    }
+
+    widgetadaptor cat {
+        component comp1
+        component comp1a
+    }
+
+    set a [lsort [dog info components]]
+    set b [lsort [cat info components]]
+    list $a $b
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}}
+
+
+
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+::tcltest::cleanupTests
+return

pkgs/itcl4.2.2/tests/widgetclass.test

@@ -0,0 +1,822 @@
+#---------------------------------------------------------------------
+# TITLE:
+#       widgetclass.test
+#
+# AUTHOR:
+#       Arnulf Wiedemann with a lot of code form the snit tests by
+#       Will Duquette
+#
+# DESCRIPTION:
+#       Test cases for ::itcl::type command.
+#       Uses the ::tcltest:: harness.
+#
+#       There is at least Tcl 8.6a3 needed
+#
+#    The tests assume tcltest 2.2
+#-----------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Declare the minimal version of Tcl required to run the package
+## tested by this testsuite, and its dependencies.
+
+proc testsNeedTcl {version} {
+    # This command ensures that a minimum version of Tcl is used to
+    # run the tests in the calling testsuite. If the minimum is not
+    # met by the active interpreter we forcibly bail out of the
+    # testsuite calling the command. The command has to be called
+    # immediately after loading the utilities.
+
+    if {[package vsatisfies [package provide Tcl] ${version}-]} return
+
+    puts "    Aborting the tests found in \"[file tail [info script]]\""
+    puts "    Requiring at least Tcl $version, have [package provide Tcl]."
+
+    # This causes a 'return' in the calling scope.
+    return -code return
+}
+
+# ### ### ### ######### ######### #########
+## Declare the minimum version of Tcltest required to run the
+## testsuite.
+
+proc testsNeedTcltest {version} {
+    # This command ensure that a minimum version of the Tcltest
+    # support package is used to run the tests in the calling
+    # testsuite. If the minimum is not met by the loaded package we
+    # forcibly bail out of the testsuite calling the command. The
+    # command has to be called after loading the utilities. The only
+    # command allowed to come before it is 'textNeedTcl' above.
+
+    # Note that this command will try to load a suitable version of
+    # Tcltest if the package has not been loaded yet.
+
+    if {[lsearch [namespace children] ::tcltest] == -1} {
+	if {![catch {
+	    package require tcltest $version
+	}]} {
+	    namespace import -force ::tcltest::*
+	    return
+	}
+    } elseif {[package vcompare [package present tcltest] $version] >= 0} {
+	namespace import -force ::tcltest::*
+	return
+    }
+
+    puts "    Aborting the tests found in [file tail [info script]]."
+    puts "    Requiring at least tcltest $version, have [package present tcltest]"
+
+    # This causes a 'return' in the calling scope.
+    return -code return
+}
+
+# Set up for Tk tests: enter the event loop long enough to catch
+# any bgerrors.
+proc tkbide {{msg "tkbide"} {msec 500}} {
+    set ::bideVar 0
+    set ::bideError ""
+    set ::bideErrorInfo ""
+    # It looks like update idletasks does the job.
+    if {0} {
+        after $msec {set ::bideVar 1}
+        tkwait variable ::bideVar
+    }
+    update idletasks
+    if {"" != $::bideError} {
+        error "$msg: $::bideError" $::bideErrorInfo
+    }
+}
+
+
+
+testsNeedTcl     8.6
+testsNeedTcltest 2.2
+
+interp alias {} type {} ::itcl::type
+interp alias {} widget {} ::itcl::widget
+
+# Marks tests which are only for Tk.
+tcltest::testConstraint tk [expr {![catch {package require Tk}]}]
+
+::tcltest::loadTestedCommands
+package require itcl
+
+#-----------------------------------------------------------------------
+# Widgets
+
+# A widget is just a widgetadaptor with an automatically created hull
+# component (a Tk frame).  So the widgetadaptor tests apply; all we
+# need to test here is the frame creation.
+
+test widget-1.1 {creating a widget
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate method * to itcl_hull
+        delegate option * to itcl_hull
+    }
+
+    myframe create .frm -background green
+
+    set a [.frm cget -background]
+    set b [.frm itcl_hull]
+
+    destroy .frm
+    tkbide
+    list $a $b
+} -cleanup {
+    myframe destroy
+} -result {green ::itcl::internal::widgets::hull1.frm}
+
+test widget-2.1 {can't redefine hull
+} -constraints {
+    tk
+} -body {
+    # there is no need to define or set itcl_hull as that is done automatically
+    widget myframe {
+        method resethull {} {
+	set itcl_hull ""
+	}
+    }
+
+    myframe .frm
+
+    .frm resethull
+} -returnCodes {
+    error
+} -cleanup {
+    myframe destroy
+} -result {can't set "itcl_hull": The itcl_hull component cannot be redefined}
+
+
+#-----------------------------------------------------------------------
+# install
+#
+# The install command is used to install widget components, while getting
+# options for the option database.
+
+test install-1.1 {installed components are created properly
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        # Delegate an option just to make sure the component variable
+        # exists.
+        delegate option -font to text
+
+        constructor {args} {
+            installcomponent text using text $win.text -background green
+        }
+
+        method getit {} {
+            $win.text cget -background
+        }
+    }
+
+    myframe .frm
+    set a [.frm getit]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {green}
+
+test install-1.2 {installed components are saved properly
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        # Delegate an option just to make sure the component variable
+        # exists.
+        delegate option -font to text
+
+        constructor {args} {
+            installcomponent text using text $win.text -background green
+        }
+
+        method getit {} {
+            $text cget -background
+        }
+    }
+
+    myframe .frm
+    set a [.frm getit]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {green}
+
+test install-1.4 {install queries option database
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option -font to text
+
+        typeconstructor {
+            option add *Myframe.font Courier
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -font]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {Courier}
+
+test install-1.5 {explicit options override option database
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option -font to text
+
+        typeconstructor {
+            option add *Myframe.font Courier
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text -font Times
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -font]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {Times}
+
+test install-1.6 {option db works with targetted options
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option -textfont to text as -font
+
+        typeconstructor {
+            option add *Myframe.textfont Courier
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -textfont]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {Courier}
+
+test install-1.8 {install can install non-widget components
+} -constraints {
+    tk
+} -body {
+    type dog {
+        option -tailcolor black
+    }
+
+    widget myframe {
+        delegate option -tailcolor to thedog
+
+        typeconstructor {
+            option add *Myframe.tailcolor green
+        }
+
+        constructor {args} {
+            installcomponent thedog using dog $win.dog
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -tailcolor]
+    destroy .frm
+    tkbide
+    set a
+
+} -cleanup {
+    dog destroy
+    myframe destroy
+} -result {green}
+
+test install-1.9 {ok if no options are delegated to component
+} -constraints {
+    tk
+} -body {
+    type dog {
+        option -tailcolor black
+    }
+
+    widget myframe {
+        constructor {args} {
+            installcomponent thedog using dog $win.dog
+        }
+    }
+
+    myframe .frm
+    destroy .frm
+    tkbide
+
+    # Test passes if no error is raised.
+    list ok
+} -cleanup {
+    myframe destroy
+    dog destroy
+} -result {ok}
+
+test install-2.1 {
+    delegate option * for a non-shadowed option.  The text widget's
+    -foreground and -font options should be set according to what's
+    in the option database on the widgetclass.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option * to text
+
+        typeconstructor {
+            option add *Myframe.foreground red
+            option add *Myframe.font {Times 14}
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -foreground]
+    set b [.frm cget -font]
+    destroy .frm
+    tkbide
+
+    list $a $b
+} -cleanup {
+    myframe destroy
+} -result {red {Times 14}}
+
+
+test install-2.2 {
+    Delegate option * for a shadowed option.  Foreground is declared
+    as a non-delegated option, hence it will pick up the option database
+    default.  -foreground is not included in the "delegate option *", so
+    the text widget's -foreground option will not be set from the
+    option database.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        option -foreground white
+        delegate option * to text
+
+        typeconstructor {
+            option add *Myframe.foreground red
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text
+        }
+
+        method getit {} {
+            $text cget -foreground
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -foreground]
+    set b [.frm getit]
+    destroy .frm
+    tkbide
+
+    expr {![string equal $a $b]}
+} -cleanup {
+    myframe destroy
+} -result {1}
+
+test install-2.3 {
+    Delegate option * for a creation option.  Because the text widget's
+    -foreground is set explicitly by the constructor, that always
+    overrides the option database.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option * to text
+
+        typeconstructor {
+            option add *Myframe.foreground red
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text -foreground blue
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -foreground]
+    destroy .frm
+    tkbide
+
+    set a
+} -cleanup {
+    myframe destroy
+} -result {blue}
+
+test install-2.4 {
+    Delegate option * with an excepted option.  Because the text widget's
+    -state is excepted, it won't be set from the option database.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option * to text except -state
+
+        typeconstructor {
+            option add *Myframe.foreground red
+            option add *Myframe.state disabled
+        }
+
+        constructor {args} {
+            installcomponent text using text $win.text
+        }
+
+        method getstate {} {
+            $text cget -state
+        }
+    }
+
+    myframe .frm
+    set a [.frm getstate]
+    destroy .frm
+    tkbide
+
+    set a
+} -cleanup {
+    myframe destroy
+} -result {normal}
+
+
+#-----------------------------------------------------------------------
+# Advanced installhull tests
+#
+# installhull is used to install the hull widget for both widgets and
+# widget adaptors.  It has two forms.  In one form it installs a widget
+# created by some third party; in this form no querying of the option
+# database is needed, because we haven't taken responsibility for creating
+# it.  But in the other form (installhull using) installhull actually
+# creates the widget, and takes responsibility for querying the
+# option database as needed.
+#
+# NOTE: "installhull using" is always used to create a widget's hull frame.
+#
+# That options passed into installhull override those from the
+# option database.
+
+test installhull-1.1 {
+    options delegated to a widget's itcl_hull frame with the same name are
+    initialized from the option database.  Note that there's no
+    explicit code in Snit to do this; it happens because we set the
+    -class when the widget was created.  In fact, it happens whether
+    we delegate the option name or not.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option -background to itcl_hull
+
+        typeconstructor {
+            option add *Myframe.background red
+            option add *Myframe.width 123
+        }
+
+        method getwid {} {
+            $itcl_hull cget -width
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -background]
+    set b [.frm getwid]
+    destroy .frm
+    tkbide
+    list $a $b
+} -cleanup {
+    myframe destroy
+} -result {red 123}
+
+test installhull-1.2 {
+    Options delegated to a widget's itcl_hull frame with a different name are
+    initialized from the option database.
+} -constraints {
+    tk
+} -body {
+    widget myframe {
+        delegate option -mainbackground to itcl_hull as -background
+
+        typeconstructor {
+            option add *Myframe.mainbackground green
+        }
+    }
+
+    myframe .frm
+    set a [.frm cget -mainbackground]
+    destroy .frm
+    tkbide
+    set a
+} -cleanup {
+    myframe destroy
+} -result {green}
+
+
+
+test option-5.1 {local widget options read from option database
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        option -foo a
+        option -bar b
+
+        typeconstructor {
+            option add *Dog.bar bb
+        }
+    }
+
+    dog .fido
+    set a [.fido cget -foo]
+    set b [.fido cget -bar]
+    destroy .fido
+    tkbide
+
+    list $a $b
+
+} -cleanup {
+    dog destroy
+} -result {a bb}
+
+test option-5.2 {local option database values available in constructor
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        option -bar b
+        variable saveit
+
+        typeconstructor {
+            option add *Dog.bar bb
+        }
+
+        constructor {args} {
+            set saveit $itcl_options(-bar)
+        }
+
+        method getit {} {
+            return $saveit
+        }
+    }
+
+    dog .fido
+    set result [.fido getit]
+    destroy .fido
+    tkbide
+
+    set result
+} -cleanup {
+    dog destroy
+} -result {bb}
+
+#-----------------------------------------------------------------------
+# Setting the widget class explicitly
+
+test widgetclass-1.3 {widgetclass must begin with uppercase letter
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        widgetclass dog
+    }
+} -returnCodes {
+    error
+} -result {widgetclass "dog" does not begin with an uppercase letter}
+
+test widgetclass-1.4 {widgetclass can only be defined once
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        widgetclass Dog
+        widgetclass Dog
+    }
+} -returnCodes {
+    error
+} -result {too many widgetclass statements}
+
+test widgetclass-1.5 {widgetclass set successfully
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        widgetclass DogWidget
+    }
+
+    # The test passes if no error is thrown.
+    list ok
+} -cleanup {
+    dog destroy
+} -result {ok}
+
+test widgetclass-1.6 {implicit widgetclass applied to hull
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        typeconstructor {
+            option add *Dog.background green
+        }
+
+        method background {} {
+            $itcl_hull cget -background
+        }
+    }
+
+    dog .dog
+
+    set bg [.dog background]
+
+    destroy .dog
+
+    set bg
+} -cleanup {
+    dog destroy
+} -result {green}
+
+test widgetclass-1.7 {explicit widgetclass applied to hull
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        widgetclass DogWidget
+
+        typeconstructor {
+            option add *DogWidget.background yellow
+        }
+
+        method background {} {
+            $itcl_hull cget -background
+        }
+    }
+
+    dog .dog
+
+    set bg [.dog background]
+
+    destroy .dog
+
+    set bg
+} -cleanup {
+    dog destroy
+} -result {yellow}
+
+#-----------------------------------------------------------------------
+# hulltype statement
+
+test hulltype-1.3 {hulltype can be frame
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        delegate option * to itcl_hull
+        hulltype frame
+    }
+
+    dog .fido
+    catch {.fido configure -use} result
+    destroy .fido
+    tkbide
+
+    set result
+} -cleanup {
+    dog destroy
+} -result {unknown option "-use"}
+
+test hulltype-1.4 {hulltype can be toplevel
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        delegate option * to itcl_hull
+        hulltype toplevel
+    }
+
+    dog .fido
+    catch {.fido configure -use} result
+    destroy .fido
+    tkbide
+
+    set result
+} -cleanup {
+    dog destroy
+} -result {-use use Use {} {}}
+
+test hulltype-1.5 {hulltype can only be defined once
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        hulltype frame
+        hulltype toplevel
+    }
+} -returnCodes {
+    error
+} -result {too many hulltype statements}
+
+test hulltype-2.1 {list of valid hulltypes
+} -constraints {
+    tk
+} -body {
+    type dog {
+    }
+
+    lsort [dog info hulltypes]
+} -cleanup {
+    dog destroy
+} -result {frame labelframe toplevel ttk:frame ttk:labelframe ttk:toplevel}
+
+test winfo-10.1 {widget info widgets
+} -constraints {
+    tk
+} -body {
+    widget dog {
+    }
+
+    widget cat {
+    }
+
+    lsort [dog info widgets]
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {cat dog}
+
+test winfo-10.2 {widget info components
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        component comp1
+        component comp2
+    }
+
+    widget cat {
+        component comp1
+        component comp1a
+    }
+
+    set a [lsort [dog info components]]
+    set b [lsort [cat info components]]
+    list $a $b
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}}
+
+test winfo-10.3 {widget info widgetclasses
+} -constraints {
+    tk
+} -body {
+    widget dog {
+        widgetclass DogWidget
+    }
+
+    widget cat {
+        widgetclass CatWidget
+    }
+
+    lsort [dog info widgetclasses]
+} -cleanup {
+    dog destroy
+    cat destroy
+} -result {CatWidget DogWidget}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+::tcltest::cleanupTests
+return