--- /dev/null
+# -*- tcl -*-
+#---------------------------------------------------------------------
+# TITLE:
+# snit.test
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Test cases for snit.tcl. Uses the ::tcltest:: harness.
+#
+# If Tcl is 8.5, Snit 2.0 is loaded.
+# If Tcl is 8.4, Snit 1.2 is loaded.
+# If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport).
+#
+# Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg
+# Backport of test made general by Andreas Kupries.
+#
+# The tests assume tcltest 2.2
+
+#-----------------------------------------------------------------------
+# Back-port to Tcl8.3 by Kenneth Green (kmg)
+#
+# Global changes:
+# " eq " => "string equal"
+# " ne " -> "!string equal"
+#-----------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 2.2
+
+#---------------------------------------------------------------------
+# Set up a number of constraints. This also determines which
+# implementation of snit is loaded and tested.
+
+# WHD: Work around bugs in 8.5a3
+tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}]
+
+# Marks tests which are only for Tk.
+tcltest::testConstraint tk [info exists tk_version]
+
+# If Tk is available, require BWidget
+tcltest::testConstraint bwidget [expr {
+ [tcltest::testConstraint tk] &&
+ ![catch {package require BWidget}]
+}]
+
+# Determine which Snit version to load. If Tcl 8.5, use 2.x.
+# Otherwise, use 1.x. (Different variants depending on 8.3 vs 8.4)
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ set snitVersion 2
+ set snitFile snit2.tcl
+} else {
+ set snitVersion 1
+ set snitFile snit.tcl
+}
+
+# Marks tests which are only for Snit 1
+tcltest::testConstraint snit1 [expr {$snitVersion == 1}]
+
+# Marks tests which are only for Snit 2
+tcltest::testConstraint snit2 [expr {$snitVersion == 2}]
+
+# Marks tests which are only for Snit 1 with Tcl 8.3
+tcltest::testConstraint tcl83 [string equal [info tclversion] "8.3"]
+tcltest::testConstraint tcl84 [package vsatisfies [package present Tcl] 8.4]
+
+if {[package vsatisfies [package provide Tcl] 8.6]} {
+ # 8.6+
+ proc expect {six default} { return $six }
+} else {
+ # 8.4/8.5
+ proc expect {six default} { return $default }
+}
+
+#---------------------------------------------------------------------
+# Load the snit package.
+
+testing {
+ useLocal $snitFile snit
+}
+
+#---------------------------------------------------------------------
+
+namespace import ::snit::*
+
+# Set up for Tk tests: Repeat background errors
+proc bgerror {msg} {
+ global errorInfo
+ set ::bideError $msg
+ set ::bideErrorInfo $errorInfo
+}
+
+# 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
+ }
+}
+
+# cleanup type
+proc cleanupType {name} {
+ if {[namespace exists $name]} {
+ if {[catch {$name destroy} result]} {
+ global errorInfo
+ puts $errorInfo
+ error "Could not cleanup $name!"
+ }
+ }
+ tkbide "cleanupType $name"
+}
+
+# cleanup before each test
+proc cleanup {} {
+ global errorInfo
+
+ cleanupType ::dog
+ cleanupType ::cat
+ cleanupType ::mylabel
+ cleanupType ::myframe
+ cleanupType ::foo
+ cleanupType ::bar
+ cleanupType ::tail
+ cleanupType ::papers
+ cleanupType ::animal
+ cleanupType ::confused-dog
+ catch {option clear}
+
+ if {![string equal [info commands "spot"] ""]} {
+ puts "spot not erased!"
+ error "spot not erased!"
+ }
+
+ if {![string equal [info commands "fido"] ""]} {
+ puts "fido not erased!"
+ error "fido not erased!"
+ }
+}
+
+# catch error code and error
+
+proc codecatch {command} {
+ if {![catch {uplevel 1 $command} result]} {
+ error "expected error, got OK"
+ }
+
+ return "$::errorCode $result"
+}
+
+
+#-----------------------------------------------------------------------
+# Internals: tests for Snit utility functions
+
+test Expand-1.1 {template, no arguments} -body {
+ snit::Expand "My %TEMPLATE%"
+} -result {My %TEMPLATE%}
+
+test Expand-1.2 {template, no matching arguments} -body {
+ snit::Expand "My %TEMPLATE%" %FOO% foo
+} -result {My %TEMPLATE%}
+
+test Expand-1.3 {template with matching arguments} -body {
+ snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
+} -result {bar foo bar}
+
+test Expand-1.4 {template with odd number of arguments} -body {
+ snit::Expand "%FOO% %BAR% %FOO%" %FOO%
+} -result {char map list unbalanced} -returnCodes error
+
+test Mappend-1.1 {template, no arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "My %TEMPLATE%"
+} -cleanup {
+ unset text
+} -result {Prefix: My %TEMPLATE%}
+
+test Mappend-1.2 {template, no matching arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "My %TEMPLATE%" %FOO% foo
+} -cleanup {
+ unset text
+} -result {Prefix: My %TEMPLATE%}
+
+test Mappend-1.3 {template with matching arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
+} -cleanup {
+ unset text
+} -result {Prefix: bar foo bar}
+
+test Mappend-1.4 {template with odd number of arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "%FOO% %BAR% %FOO%" %FOO%
+} -cleanup {
+ unset text
+} -returnCodes error -result {char map list unbalanced}
+
+test RT.UniqueName-1.1 {no name collision} -body {
+ set counter 0
+
+ # Standard qualified type name.
+ set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%]
+
+ # Standard qualified widget name.
+ set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%]
+
+ list $n1 $n2
+} -result {::my::mytype1 .my.mytype2} -cleanup {
+ unset counter n1 n2
+}
+
+test RT.UniqueName-1.2 {name collision} -body {
+ set counter 0
+
+ # Create the first two equivalent procs.
+ proc ::mytype1 {} {}
+ proc ::mytype2 {} {}
+
+ # Create a new name; it should skip to 3.
+ snit::RT.UniqueName counter ::mytype ::%AUTO%
+} -cleanup {
+ unset counter
+ rename ::mytype1 ""
+ rename ::mytype2 ""
+} -result {::mytype3}
+
+test RT.UniqueName-1.3 {nested type name} -body {
+ set counter 0
+
+ snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO%
+} -cleanup {
+ unset counter
+} -result {::your::yourtype1}
+
+test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup {
+ namespace eval ::mytype:: {}
+} -body {
+ set counter 0
+ snit::RT.UniqueInstanceNamespace counter ::mytype
+} -cleanup {
+ unset counter
+ namespace delete ::mytype::
+} -result {::mytype::Snit_inst1}
+
+test RT.UniqueInstanceNamespace-1.2 {name collision} -setup {
+ namespace eval ::mytype:: {}
+ namespace eval ::mytype::Snit_inst1:: {}
+ namespace eval ::mytype::Snit_inst2:: {}
+} -body {
+ set counter 0
+
+ # Should skip to 3.
+ snit::RT.UniqueInstanceNamespace counter ::mytype
+} -cleanup {
+ unset counter
+ namespace delete ::mytype::
+} -result {::mytype::Snit_inst3}
+
+test Contains-1.1 {contains element} -constraints {
+ snit1
+} -setup {
+ set mylist {foo bar baz}
+} -body {
+ snit::Contains baz $mylist
+} -cleanup {
+ unset mylist
+} -result {1}
+
+test Contains-1.2 {does not contain element} -constraints {
+ snit1
+} -setup {
+ set mylist {foo bar baz}
+} -body {
+ snit::Contains quux $mylist
+} -cleanup {
+ unset mylist
+} -result {0}
+
+#-----------------------------------------------------------------------
+# type compilation
+
+# snit::compile returns two values, the qualified type name
+# and the script to execute to define the type. This section
+# only checks the length of the list and the type name;
+# the content of the script is validated by the remainder
+# of this test suite.
+
+test compile-1.1 {compile returns qualified type} -body {
+ set compResult [compile type dog { }]
+
+ list [llength $compResult] [lindex $compResult 0]
+} -result {2 ::dog}
+
+#-----------------------------------------------------------------------
+# 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 {}}
+
+test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
+ type dog {}
+ namespace eval dog::unrelated {}
+ dog destroy
+} -result {}
+
+#-----------------------------------------------------------------------
+# 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 {too many typeconstructors}
+
+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.2 {typecomponent trace executes} -body {
+ type dog {
+ typecomponent mycomp
+
+ typemethod test {} {
+ typevariable Snit_typecomponents
+ set mycomp foo
+ return $Snit_typecomponents(mycomp)
+ }
+ }
+
+ dog test
+} -cleanup {
+ dog destroy
+} -result {foo}
+
+test typecomponent-1.3 {typecomponent -public works} -body {
+ type dog {
+ typecomponent mycomp -public string
+
+ typeconstructor {
+ set mycomp string
+ }
+ }
+
+ dog string length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+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}
+
+
+#-----------------------------------------------------------------------
+# hierarchical type methods
+
+test htypemethod-1.1 {hierarchical method, two tokens} -body {
+ type dog {
+ typemethod {wag tail} {} {
+ return "wags tail"
+ }
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail}
+
+test htypemethod-1.2 {hierarchical method, three tokens} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {
+ return "wags tail proudly"
+ }
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {wags tail proudly}
+
+test htypemethod-1.3 {hierarchical method, four tokens} -body {
+ type dog {
+ typemethod {wag tail really high} {} {
+ return "wags tail really high"
+ }
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+} -result {wags tail really high}
+
+test htypemethod-1.4 {redefinition is OK} -body {
+ type dog {
+ typemethod {wag tail} {} {
+ return "wags tail"
+ }
+ typemethod {wag tail} {} {
+ return "wags tail briskly"
+ }
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail briskly}
+
+# Case 1
+test htypemethod-1.5 {proper error on missing submethod} -constraints {
+ snit1
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {wrong number args: should be "::dog wag method args"}
+
+# Case 2
+test htypemethod-1.6 {proper error on missing submethod} -constraints {
+ snit2
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "dog wag subcommand ?arg ...?"} \
+ {wrong # args: should be "dog wag subcommand ?argument ...?"}]
+
+# Case 1
+test htypemethod-1.7 {proper error on bogus submethod} -constraints {
+ snit1
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag ears
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog wag ears" is not defined}
+
+# Case 2
+test htypemethod-1.8 {proper error on bogus submethod} -constraints {
+ snit2
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag ears
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "ears": namespace ::dog does not export any commands}
+
+test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body {
+ type dog {
+ typemethod wag {} {}
+ typemethod {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail}...", "wag" has no submethods.}
+
+test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ typemethod wag {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod wag...", "wag" has submethods.}
+
+test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ typemethod {wag tail proudly} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}
+
+test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {}
+ typemethod {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# 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}
+
+# Case 1
+test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints {
+ snit1
+} -body {
+ type dog {
+ delegate typemethod length to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo bar
+} -returnCodes {
+ error
+} -result {wrong # args: should be "string length string"}
+
+# Case 2
+test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints {
+ snit2
+} -body {
+ type dog {
+ delegate typemethod length to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo bar
+} -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}
+
+# Case 1
+test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body {
+ type dog {
+ delegate typemethod * to stringhandler
+
+ typeconstructor {
+ set stringhandler string
+ }
+ }
+
+ dog foo bar
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}
+
+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
+} -constraints {
+ snit2
+} -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 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}
+
+# Case 1
+test dtypemethod-1.9 {excepted methods are caught properly} -constraints {
+ snit1
+} -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 {"::dog match" is not defined} {"::dog index" is not defined}}
+
+# Case 2
+test dtypemethod-1.10 {excepted methods are caught properly} -constraints {
+ snit2
+} -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 wag} using {echo %% %t %M %m %j %n %w %s %c}
+ }
+
+ dog tail wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {% ::dog {tail wag} wag tail_wag %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.1 {hierarchical typemethod, two tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail} to tail as wag
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail proudly} to tail as wag
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail really high} to tail as wag
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.4 {redefinition is OK} -body {
+ type tail {
+ method {wag tail} {} {return "wags tail"}
+ method {wag briskly} {} {return "wags tail briskly"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail} to tail as {wag tail}
+ delegate typemethod {wag tail} to tail as {wag briskly}
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail briskly}
+
+test dtypemethod-4.5 {last token is used by default} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail wag} to tail
+ }
+
+ dog tail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.6 {last token can be *} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail
+ }
+
+ list [dog tail wag] [dog tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags droops}
+
+# Case 2
+test dtypemethod-4.7 {except with multiple tokens} -constraints {
+ snit1
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail except droop
+ }
+
+ catch {dog tail droop} result
+
+ list [dog tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {"::dog tail droop" is not defined}}
+
+# Case 2
+test dtypemethod-4.8 {except with multiple tokens} -constraints {
+ snit2
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail except droop
+ }
+
+ catch {dog tail droop} result
+
+ list [dog tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}}
+
+test dtypemethod-4.9 {"*" in the wrong spot} -body {
+ type dog {
+ delegate typemethod {tail * wag} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}
+
+test dtypemethod-5.1 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod wag to tail
+ delegate typemethod {wag tail} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}
+
+test dtypemethod-5.2 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail} to tail as wag
+ delegate typemethod wag to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod wag...", "wag" has submethods.}
+
+test dtypemethod-5.3 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail} to tail
+ delegate typemethod {wag tail proudly} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}
+
+test dtypemethod-5.4 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail proudly} to tail as wag
+ delegate typemethod {wag tail} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# 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 {::mydog1}
+
+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.}
+
+# Case 1
+test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ $mydog destroy
+ dog destroy
+} -result {::dog1}
+
+# Case 2
+test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ # WHD: In Snit 1.0, this pragma was not needed.
+ pragma -hastypemethods no
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ # [dog destroy] doesn't exist
+ $mydog destroy
+ namespace delete ::dog
+} -result {::dog1}
+
+# Case 1
+test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "::dog method args"}
+
+# Case 2
+test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+# Case 1
+test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints {
+ snit1 tk
+} -body {
+ widget dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "::dog method args"}
+
+# Case 2
+test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints {
+ snit2 tk
+} -body {
+ widget dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -result {::dog1}
+
+test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+test creation-2.1 {Can't call "destroy" in constructor} -body {
+ type dog {
+ constructor {} {
+ $self destroy
+ }
+ }
+
+ dog spot
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {Error in constructor: Called 'destroy' method in constructor}
+
+#-----------------------------------------------------------------------
+# 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}
+
+# Case 1
+test method-1.5 {unknown methods get an error} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog create spot
+ set result ""
+ spot chase
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {"::spot chase" is not defined}
+
+# Case 2
+test method-1.6 {unknown methods get an error} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog create spot
+ set result ""
+ spot chase
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands}
+
+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"}
+
+# Case 1
+test method-1.10 {too few arguments} -constraints {
+ snit1
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+ spot bark
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4]
+
+# Case 2
+test method-1.11 {too few arguments} -constraints {
+ snit2
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+ spot bark
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "spot bark volume"}
+
+# Case 1
+test method-1.12 {too many arguments} -constraints {
+ snit1
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+
+ spot bark really loud
+} -returnCodes {
+ error
+} -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}]
+
+# Case 2
+test method-1.13 {too many arguments} -constraints {
+ snit2
+} -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}
+
+#-----------------------------------------------------------------------
+# hierarchical methods
+
+test hmethod-1.1 {hierarchical method, two tokens} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail.}
+
+test hmethod-1.2 {hierarchical method, three tokens} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail proudly."
+ }
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail proudly.}
+
+test hmethod-1.3 {hierarchical method, three tokens} -body {
+ type dog {
+ method {wag tail really high} {} {
+ return "$self wags tail really high."
+ }
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail really high.}
+
+test hmethod-1.4 {redefinition is OK} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ method {wag tail} {} {
+ return "$self wags tail briskly."
+ }
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail briskly.}
+
+# Case 1
+test hmethod-1.5 {proper error on missing submethod} -constraints {
+ snit1
+} -body {
+ type dog {
+ method {wag tail} {} { }
+ }
+
+ dog spot
+ spot wag
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong number args: should be "::spot wag method args"}
+
+# Case 2
+test hmethod-1.6 {proper error on missing submethod} -constraints {
+ snit2
+} -body {
+ type dog {
+ method {wag tail} {} { }
+ }
+
+ dog spot
+ spot wag
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "spot wag subcommand ?arg ...?"} \
+ {wrong # args: should be "spot wag subcommand ?argument ...?"}]
+
+test hmethod-1.7 {submethods called in proper objects} -body {
+ # NOTE: This test was added in response to a bug report by
+ # Anton Kovalenko. In Snit 2.0, submethod ensembles were
+ # created in the type namespace. If a type defines a submethod
+ # ensemble, then all objects of that type would end up sharing
+ # a single ensemble. Ensembles are created lazily, so in this
+ # test, the first call to "fido this tail wag" and "spot this tail wag"
+ # will yield the correct result, but the second call to
+ # "fido this tail wag" will yield the same as the call to
+ # "spot this tail wag", because spot's submethod ensemble has
+ # displaced fido's. Until the bug is fixed, that is.
+ #
+ # Fortunately, Anton provided the fix as well.
+ type tail {
+ option -manner
+
+ method wag {} {
+ return "wags tail $options(-manner)"
+ }
+ }
+
+ type dog {
+ delegate option -manner to tail
+ delegate method {this tail wag} to tail
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ $self configurelist $args
+ }
+ }
+
+ dog fido -manner briskly
+ dog spot -manner slowly
+
+ list [fido this tail wag] [spot this tail wag] [fido this tail wag]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}}
+
+test hmethod-2.1 {prefix/method collision} -body {
+ type dog {
+ method wag {} {}
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail}...", "wag" has no submethods.}
+
+test hmethod-2.2 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ method wag {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "method wag...", "wag" has submethods.}
+
+test hmethod-2.3 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {}
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}
+
+test hmethod-2.4 {prefix/method collision} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ method {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# mymethod and renaming
+
+test 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
+} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}}
+
+test 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
+} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot}
+
+test rename-1.3 {rename to "" deletes an instance} -constraints {
+ bug8.5a3
+} -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} -constraints {
+ bug8.5a3
+} -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} -constraints {
+ bug8.5a3
+} -body {
+ type dog {
+ # Can't even test this normally.
+ pragma -canreplace yes
+ }
+
+ dog fido
+ set a [namespace children ::dog]
+ dog fido
+ set b [namespace children ::dog]
+ fido destroy
+ set c [namespace children ::dog]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}}
+
+#-----------------------------------------------------------------------
+# mymethod actually works
+
+test mymethod-1.1 {run mymethod handler} -body {
+ type foo {
+ option -command {}
+ method runcmd {} {
+ eval [linsert $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 $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}}
+
+#-----------------------------------------------------------------------
+# typevariable
+
+test typevariable-1.1 {typevarname qualifies typevariables} -body {
+ # Note: typevarname is DEPRECATED. Real code should use
+ # mytypevar instead.
+ type dog {
+ method tvname {name} {
+ typevarname $name
+ }
+ }
+
+ dog create spot
+ spot tvname myvar
+} -cleanup {
+ dog destroy
+} -result {::dog::myvar}
+
+test typevariable-1.2 {undefined typevariables are OK} -body {
+ type dog {
+ method tset {value} {
+ typevariable theValue
+
+ set theValue $value
+ }
+
+ method tget {} {
+ typevariable theValue
+
+ 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] [set ::dog::greeting]
+} -cleanup {
+ dog destroy
+} -result {Hello 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 {Error in "typevariable color...", too many initializers}
+
+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 {Error in "typevariable color...", too many initializers}
+
+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
+} -result {::dog::Snit_inst1::somevar}
+
+test ivariable-1.2 {undefined instance variables are OK} -body {
+ type dog {
+ method setgreeting {value} {
+ variable greeting
+
+ set greeting $value
+ }
+
+ method getgreeting {} {
+ variable greeting
+
+ return $greeting
+ }
+ }
+
+ set spot [dog create spot]
+ spot setgreeting Hey
+
+ dog create fido
+ fido setgreeting Howdy
+
+ list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting]
+} -cleanup {
+ dog destroy
+} -result {Hey Howdy Hey}
+
+test ivariable-1.3 {instance variables are destroyed automatically} -body {
+ type dog {
+ constructor {args} {
+ variable greeting
+
+ set greeting Hi
+ }
+ }
+
+ dog create spot
+ set g1 $::dog::Snit_inst1::greeting
+
+ spot destroy
+ list $g1 [info exists ::dog::Snit_inst1::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.7 {variable is illegal when selfns is undefined} -body {
+ type dog {
+ method caller {} {
+ callee
+ }
+ proc callee {} {
+ variable foo
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't read "selfns": no such variable}
+
+test ivariable-1.8 {myvar is illegal when selfns is undefined} -body {
+ type dog {
+ method caller {} {
+ callee
+ }
+ proc callee {} {
+ myvar foo
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't read "selfns": no such variable}
+
+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 $greeting
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test ivariable-1.10 {in methods, variable works with fully qualified names} -body {
+ namespace eval ::somenamespace:: {
+ set somevar somevalue
+ }
+
+ type dog {
+ method get {} {
+ variable ::somenamespace::somevar
+ return $somevar
+ }
+ }
+
+ dog create spot
+
+ spot get
+} -cleanup {
+ dog destroy
+} -result {somevalue}
+
+test ivariable-1.11 {variable with too many initializers throws an error} -body {
+ type dog {
+ variable color dark brown
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable color...", too many initializers}
+
+test ivariable-1.12 {variable with too many initializers throws an error} -body {
+ type dog {
+ variable color -array dark brown
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable color...", too many initializers}
+
+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}
+
+#-----------------------------------------------------------------------
+# codename
+#
+# NOTE: codename is deprecated; myproc should be used instead.
+
+test codename-1.1 {codename qualifies procs} -body {
+ type dog {
+ method qualify {} {
+ return [codename myproc]
+ }
+ proc myproc {} { }
+ }
+ dog create spot
+ spot qualify
+} -cleanup {
+ dog destroy
+} -result {::dog::myproc}
+
+test codename-1.2 {procs with selfns work} -body {
+ type dog {
+ variable datum foo
+
+ method qualify {} {
+ return [list [codename getdatum] $selfns]
+ }
+ proc getdatum {selfns} {
+ return $datum
+ }
+ }
+ dog create spot
+ eval [spot qualify]
+} -cleanup {
+ dog destroy
+} -result {foo}
+
+#-----------------------------------------------------------------------
+# 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 $options(-color) $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 options(-color) black
+ set 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 {}
+
+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
+ spot configure
+} -cleanup {
+ dog destroy
+} -result {{-color color Color black red} {-akc akc Akc 1 0}}
+
+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
+} -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-2.5 {configure returns info, unknown options} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option -width to hull
+ delegate option * to hull
+ constructor {args} {
+ 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 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 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 {Error in "option nohyphen...", badly named option "nohyphen"}
+
+test option-4.2 {local option name must be lower case} -body {
+ type dog {
+ option -Upper
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -Upper...", badly named option "-Upper"}
+
+test option-4.3 {local option name may not contain spaces} -body {
+ type dog {
+ option {"-with space"}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {"-with space"}...", badly named option "-with space"}
+
+test option-4.4 {delegated option name must begin with hyphen} -body {
+ type dog {
+ delegate option nohyphen to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option nohyphen...", badly named option "nohyphen"}
+
+test option-4.5 {delegated option name must be lower case} -body {
+ type dog {
+ delegate option -Upper to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option -Upper...", badly named option "-Upper"}
+
+test option-4.6 {delegated option name may not contain spaces} -body {
+ type dog {
+ delegate option {"-with space"} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option {"-with space"}...", badly named option "-with space"}
+
+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 $options(-bar)
+ }
+
+ method getit {} {
+ return $saveit
+ }
+ }
+
+ dog .fido
+ set result [.fido getit]
+ destroy .fido
+ tkbide
+
+ set result
+} -cleanup {
+ dog destroy
+} -result {bb}
+
+test option-6.1 {if no options, no options variable} -body {
+ type dog {
+ variable dummy
+ }
+
+ dog spot
+ spot info vars options
+} -cleanup {
+ dog destroy
+} -result {}
+
+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 {}
+
+#-----------------------------------------------------------------------
+# onconfigure
+
+test onconfigure-1.1 {invalid onconfigure methods are caught} -body {
+ type dog {
+ onconfigure -color {value} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color: option "-color" unknown}
+
+test onconfigure-1.2 {onconfigure methods take one argument} -body {
+ type dog {
+ option -color golden
+
+ onconfigure -color {value badarg} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color handler should have one argument, got "value badarg"}
+
+test onconfigure-1.3 {onconfigure methods work} -body {
+ type dog {
+ option -color golden
+
+ onconfigure -color {value} {
+ set options(-color) "*$value*"
+ }
+ }
+
+ dog create spot
+ spot configure -color brown
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {*brown*}
+
+test onconfigure-1.4 {onconfigure arg can't be type} -body {
+ type dog {
+ option -color
+ onconfigure -color {type} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color's arglist may not contain "type" explicitly}
+
+test onconfigure-1.5 {onconfigure arg can't be self} -body {
+ type dog {
+ option -color
+ onconfigure -color {self} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color's arglist may not contain "self" explicitly}
+
+#-----------------------------------------------------------------------
+# oncget
+
+test oncget-1.1 {invalid oncget methods are caught} -body {
+ type dog {
+ oncget -color { }
+ }
+} -returnCodes {
+ error
+} -result {Error in "oncget -color...", option "-color" unknown}
+
+test oncget-1.2 {oncget methods work} -body {
+ cleanup
+
+ type dog {
+ option -color golden
+
+ oncget -color {
+ return "*$options(-color)*"
+ }
+ }
+
+ dog create spot
+ spot configure -color brown
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {*brown*}
+
+#-----------------------------------------------------------------------
+# 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 configurelist $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 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 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
+} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
+
+#-----------------------------------------------------------------------
+# 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 b [namespace children ::dog::]
+ spot destroy
+ set c [namespace children ::dog::]
+ list $a $b $c [info commands ::dog::spot]
+} -cleanup {
+ dog destroy
+} -result {{} ::dog::Snit_inst1 {} {}}
+
+test destroy-1.2 {incomplete objects are destroyed} -body {
+ array unset ::dog::snit_ivars
+
+ type dog {
+ option -color golden
+
+ constructor {args} {
+ $self configurelist $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 {{Error in constructor: 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}}
+
+#-----------------------------------------------------------------------
+# 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 {Error in "delegate foo bar...", "foo"?}
+
+test delegate-1.2 {"to" must appear in the right place} -body {
+ type dog {
+ delegate method foo from bar
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "from"}
+
+test delegate-1.3 {"as" must have a target} -body {
+ type dog {
+ delegate method foo to bar as
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", invalid syntax}
+
+test delegate-1.4 {"as" must have a single target} -body {
+ type dog {
+ delegate method foo to bar as baz quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "quux"}
+
+test delegate-1.5 {"as" doesn't work with "*"} -body {
+ type dog {
+ delegate method * to hull as foo
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", cannot specify "as" with "*"}
+
+test delegate-1.6 {"except" must have a target} -body {
+ type dog {
+ delegate method * to bar except
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", invalid syntax}
+
+test delegate-1.7 {"except" must have a single target} -body {
+ type dog {
+ delegate method * to bar except baz quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", unknown delegation option "quux"}
+
+test delegate-1.8 {"except" works only with "*"} -body {
+ type dog {
+ delegate method foo to hull except bar
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", can only specify "except" with "*"}
+
+test delegate-1.9 {only "as" or "except"} -body {
+ type dog {
+ delegate method foo to bar with quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "with"}
+
+
+#-----------------------------------------------------------------------
+# 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}
+
+# Case 1
+test dmethod-1.3 {delegating to existing component with error} -constraints {
+ snit1
+} -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 "string length string"}
+
+# Case 2
+test dmethod-1.4 {delegating to existing component with error} -constraints {
+ snit2
+} -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.6 {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
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}
+
+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
+} -constraints {
+ snit2
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -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 dmethod-1.7 {can't delegate local method: order 1} -body {
+ type cat {
+ method foo {} {}
+ delegate method foo to hull
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", "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 {Error in "method foo...", "foo" has been delegated}
+
+# Case 1
+test dmethod-1.9 {excepted methods are caught properly} -constraints {
+ snit1
+} -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 {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}
+
+# Case 2
+test dmethod-1.10 {excepted methods are caught properly} -constraints {
+ snit2
+} -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.2 {All 'using' conversions are converted} -body {
+ proc echo {args} { return $args }
+
+ type dog {
+ delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
+ }
+
+ dog spot
+
+ spot tail wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}
+
+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}
+
+test dmethod-4.1 {hierarchical method, two tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail} to tail as wag
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.2 {hierarchical method, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail proudly} to tail as wag
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.3 {hierarchical method, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail really high} to tail as wag
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.4 {redefinition is OK} -body {
+ type tail {
+ method {wag tail} {} {return "wags tail"}
+ method {wag briskly} {} {return "wags tail briskly"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail} to tail as {wag tail}
+ delegate method {wag tail} to tail as {wag briskly}
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail briskly}
+
+test dmethod-4.5 {all tokens are used by default} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail wag} to tail
+ }
+
+ dog spot
+ spot tail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.6 {last token can be *} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail
+ }
+
+ dog spot
+
+ list [spot tail wag] [spot tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags droops}
+
+# Case 1
+test dmethod-4.7 {except with multiple tokens} -constraints {
+ snit1
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail except droop
+ }
+
+ dog spot
+
+ catch {spot tail droop} result
+
+ list [spot tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {"::spot tail droop" is not defined}}
+
+# Case 2
+test dmethod-4.8 {except with multiple tokens} -constraints {
+ snit2
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail except droop
+ }
+
+ dog spot
+
+ catch {spot tail droop} result
+
+ list [spot tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}}
+
+test dmethod-4.9 {"*" in the wrong spot} -body {
+ type dog {
+ delegate method {tail * wag} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {tail * wag}...", "*" must be the last token.}
+
+test dmethod-5.1 {prefix/method collision} -body {
+ type dog {
+ delegate method wag to tail
+ delegate method {wag tail} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail}...", "wag" has no submethods.}
+
+test dmethod-5.2 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail} to tail as wag
+ delegate method wag to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method wag...", "wag" has submethods.}
+
+test dmethod-5.3 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail} to tail
+ delegate method {wag tail proudly} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}
+
+test dmethod-5.4 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail proudly} to tail as wag
+ delegate method {wag tail} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# 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 in ::dog ::spot}
+
+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 configurelist $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 configurelist $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.5 {can't oncget for delegated option} -body {
+ type dog {
+ delegate option -color to catthing
+
+ oncget -color { }
+ }
+} -returnCodes {
+ error
+} -result {Error in "oncget -color...", option "-color" is delegated}
+
+test doption-1.6 {can't onconfigure for delegated option} -body {
+ type dog {
+ delegate option -color to catthing
+
+ onconfigure -color {value} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color: option "-color" is delegated}
+
+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 configurelist $args
+ }
+
+ delegate option * to catthing
+ }
+
+ dog create spot -colour blue
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+ cat destroy
+} -result {Error in constructor: 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 {Error in "delegate option -color...", "-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 {Error in "option -color...", cannot define "-color" locally, it has 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 configurelist {-a 1}} a
+ catch {fifi configurelist {-b 1}} b
+ catch {fifi configurelist {-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}}
+
+
+#-----------------------------------------------------------------------
+# from
+
+test from-1.1 {getting default values} -body {
+ type dog {
+ option -foo FOO
+ option -bar BAR
+
+ constructor {args} {
+ $self configure -foo [from args -foo AAA]
+ $self configure -bar [from args -bar]
+ }
+ }
+
+ dog create spot
+ list [spot cget -foo] [spot cget -bar]
+} -cleanup {
+ dog destroy
+} -result {AAA BAR}
+
+test from-1.2 {getting non-default values} -body {
+ type dog {
+ option -foo FOO
+ option -bar BAR
+ option -args
+
+ constructor {args} {
+ $self configure -foo [from args -foo]
+ $self configure -bar [from args -bar]
+ $self configure -args $args
+ }
+ }
+
+ dog create spot -foo quux -baz frobnitz -bar frobozz
+ list [spot cget -foo] [spot cget -bar] [spot cget -args]
+} -cleanup {
+ dog destroy
+} -result {quux frobozz {-baz frobnitz}}
+
+#-----------------------------------------------------------------------
+# Widgetadaptors
+
+test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+
+ delegate method * to hull
+ delegate option * to hull
+ }
+
+ mylabel create .label -text "My Label"
+
+ set a [.label cget -text]
+ set b [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 [namespace children ::mylabel]
+ destroy .label
+ set b [namespace children ::mylabel]
+ tkbide
+ list $a $b
+} -cleanup {
+ mylabel destroy
+} -result {::mylabel::Snit_inst1 {}}
+
+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 [namespace children ::mylabel]
+ destroy .lab1
+ destroy .lab2
+ set b [namespace children ::mylabel]
+ tkbide
+ list $a $b
+} -cleanup {
+ mylabel destroy
+} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
+
+test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .label
+ set a [namespace children ::mylabel]
+ rename .label ""
+ set b [namespace children ::mylabel]
+
+ mylabel destroy
+ tkbide
+ list $a $b
+} -result {::mylabel::Snit_inst1 {}}
+
+test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ mylabel create .lab2
+ set a [namespace children ::mylabel]
+ rename .lab1 ""
+ rename .lab2 ""
+ set b [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b
+} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
+
+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 ::mylabel]
+ destroy .lab1
+
+ mylabel create .lab1
+ set b [namespace children ::mylabel]
+ destroy .lab1
+
+ set c [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b $c
+} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
+
+test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ set a [namespace children ::mylabel]
+ rename .lab1 ""
+
+ mylabel create .lab1
+ set b [namespace children ::mylabel]
+ rename .lab1 ""
+
+ set c [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b $c
+} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
+
+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!}
+
+# Case 1
+test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints {
+ snit1
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ method howdy {} {return "Howdy!"}
+ }
+
+ catch {mylabel foo} result
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {"::mylabel foo" is not defined}
+
+# Case 2
+test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints {
+ snit2
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ method howdy {} {return "Howdy!"}
+ }
+
+ catch {mylabel foo} result
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {unknown subcommand "foo": namespace ::mylabel does not export any commands}
+
+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 .label} {destroyed .label}}
+
+# Case 1
+test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints {
+ snit1
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel .label
+ catch {.label destroy} result
+ destroy .label
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {".label destroy" is not defined}
+
+# Case 2
+test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints {
+ snit2
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel .label
+ catch {.label destroy} result
+ destroy .label
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands}
+
+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 {.unique1}
+
+test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+ method method1 {} {
+ return "method1"
+ }
+ delegate option * to hull
+ }
+
+ widgetadaptor mylabel2 {
+ constructor {args} {
+ installhull [mylabel $self]
+ $self configurelist $args
+ }
+ method method2 {} {
+ return "method2: [$hull method1]"
+ }
+ delegate option * to 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 [namespace children ::mylabel2]
+ set e [namespace children ::mylabel]
+
+ destroy .label
+
+ set f [namespace children ::mylabel2]
+ set g [namespace children ::mylabel]
+
+ mylabel2 destroy
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d $e $f $g
+} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
+
+test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+ method method1 {} {
+ return "method1"
+ }
+ delegate option * to hull
+ }
+
+ widgetadaptor mylabel2 {
+ constructor {args} {
+ installhull [mylabel $self]
+ $self configurelist $args
+ }
+ method method2 {} {
+ return "method2: [$hull method1]"
+ }
+ delegate option * to 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 [namespace children ::mylabel2]
+ set e [namespace children ::mylabel]
+
+ rename .label ""
+
+ set f [namespace children ::mylabel2]
+ set g [namespace children ::mylabel]
+
+ mylabel2 destroy
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d $e $f $g
+} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
+
+test widgetadaptor-1.18 {BWidget Label as hull} -constraints {
+ bwidget
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [Label $win]
+ $self configurelist $args
+ }
+ delegate option * to hull
+ }
+
+ mylabel .label -text "Some Text"
+ set a [.label cget -text]
+
+ .label configure -text "More Text"
+ set b [.label cget -text]
+
+ set c [namespace children ::mylabel]
+
+ destroy .label
+
+ set d [namespace children ::mylabel]
+
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d
+} -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}
+
+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 {Error in constructor: Simulated Error}
+
+
+#-----------------------------------------------------------------------
+# 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 {
+ method hull {} { return $hull }
+
+ delegate method * to hull
+ delegate option * to hull
+ }
+
+ myframe create .frm -background green
+
+ set a [.frm cget -background]
+ set b [.frm hull]
+
+ destroy .frm
+ tkbide
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {green ::hull1.frm}
+
+test widget-2.1 {can't redefine hull} -constraints {
+ tk
+} -body {
+ widget myframe {
+ method resethull {} { set hull "" }
+ }
+
+ myframe .frm
+
+ .frm resethull
+} -returnCodes {
+ error
+} -cleanup {
+ myframe destroy
+} -result {can't set "hull": The 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} {
+ install 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} {
+ install 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.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} {
+ install text using text $win.text -background green
+ }
+ }
+
+ myframe .frm
+} -returnCodes {
+ error
+} -cleanup {
+ myframe destroy
+} -result {Error in constructor: tried to install "text" before the hull exists}
+
+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} {
+ install 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} {
+ install 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} {
+ install 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.7 {install works for snit::types} -body {
+ type tail {
+ option -tailcolor black
+ }
+
+ type dog {
+ delegate option -tailcolor to tail
+
+ constructor {args} {
+ install tail using tail $self.tail
+ }
+ }
+
+ dog fido
+ fido cget -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {black}
+
+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} {
+ install 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} {
+ install 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} {
+ install 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} {
+ install 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} {
+ install 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} {
+ install 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 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 hull
+
+ typeconstructor {
+ option add *Myframe.background red
+ option add *Myframe.width 123
+ }
+
+ method getwid {} {
+ $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 hull frame with a different name are
+ initialized from the option database.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -mainbackground to hull as -background
+
+ typeconstructor {
+ option add *Myframe.mainbackground red
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -mainbackground]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {red}
+
+test installhull-1.3 {
+ options delegated to a widgetadaptor's 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 hull
+
+ typeconstructor {
+ option add *Frame.background red
+ option add *Frame.width 123
+ }
+
+ constructor {args} {
+ installhull using frame
+ }
+
+ method getwid {} {
+ $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 hull frame with a different name are
+ initialized from the option database.
+} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ delegate option -mainbackground to 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 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 {} {
+ $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}
+
+
+#-----------------------------------------------------------------------
+# Instance Introspection
+
+# Case 1
+test iinfo-1.1 {object info too few args} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4]
+
+# Case 2
+test iinfo-1.2 {object info too few args} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "spot info command ?arg ...?"} \
+ {wrong # args: should be "spot info command ..."}]
+
+test iinfo-1.3 {object info too many args} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info type foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}]
+
+test iinfo-2.1 {object info type} -body {
+ type dog { }
+
+ dog create spot
+ spot info type
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test iinfo-3.1 {object info typevars} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ lsort [spot info typevars]
+} -cleanup {
+ dog destroy
+} -result {::dog::thatvar ::dog::thisvar}
+
+test iinfo-3.2 {object info typevars with pattern} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ spot info typevars *this*
+} -cleanup {
+ dog destroy
+} -result {::dog::thisvar}
+
+test iinfo-4.1 {object info vars} -body {
+ type dog {
+ variable hisvar 1
+
+ constructor {args} {
+ variable hervar
+ set hervar 2
+ }
+ }
+
+ dog create spot
+ lsort [spot info vars]
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}
+
+test iinfo-4.2 {object info vars with pattern} -body {
+ type dog {
+ variable hisvar 1
+
+ constructor {args} {
+ variable hervar
+ set hervar 2
+ }
+ }
+
+ dog create spot
+ spot info vars "*his*"
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::hisvar}
+
+test iinfo-5.1 {object info no vars defined} -body {
+ type dog { }
+
+ dog create spot
+ list [spot info vars] [spot info typevars]
+} -cleanup {
+ dog destroy
+} -result {{} {}}
+
+test iinfo-6.1 {info options with no options} -body {
+ type dog { }
+ dog create spot
+
+ llength [spot info options]
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test iinfo-6.2 {info options with only local options} -body {
+ type dog {
+ option -foo a
+ option -bar b
+ }
+ dog create spot
+
+ lsort [spot info options]
+} -cleanup {
+ dog destroy
+} -result {-bar -foo}
+
+test iinfo-6.3 {info options with local and delegated options} -body {
+ type dog {
+ option -foo a
+ option -bar b
+ delegate option -quux to sibling
+ }
+ dog create spot
+
+ lsort [spot info options]
+} -cleanup {
+ dog destroy
+} -result {-bar -foo -quux}
+
+test iinfo-6.4 {info options with unknown delegated options} -constraints {
+ tk tcl83
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to 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 -relief -takefocus -visual -width}
+
+test iinfo-6.5 {info options with unknown delegated options} -constraints {
+ tk tcl84
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to 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.6 {info options with exceptions} -constraints {
+ tk tcl83
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to 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 -relief -takefocus -visual -width}
+
+test iinfo-6.7 {info options with exceptions} -constraints {
+ tk tcl84
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to 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 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 iinfo-7.1 {info typemethods, simple case} -body {
+ type dog { }
+
+ dog spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {create destroy info}
+
+test iinfo-7.2 {info typemethods, with pattern} -body {
+ type dog { }
+
+ dog spot
+
+ spot info typemethods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test iinfo-7.3 {info typemethods, with explicit typemethods} -body {
+ type dog {
+ typemethod foo {} {}
+ delegate typemethod bar to comp
+ }
+
+ dog spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {bar create destroy foo info}
+
+test iinfo-7.4 {info typemethods, with implicit typemethods} -body {
+ type dog {
+ delegate typemethod * to comp
+
+ typeconstructor {
+ set comp string
+ }
+ }
+
+ dog create spot
+
+ set a [lsort [spot info typemethods]]
+
+ dog length foo
+ dog is boolean yes
+
+ set b [lsort [spot info typemethods]]
+
+ set c [spot info typemethods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{create destroy info} {create destroy info is length} length}
+
+test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body {
+ type dog {
+ delegate typemethod {comp foo} to comp
+
+ typemethod {comp bar} {} {}
+ }
+
+ dog create spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} create destroy info}
+
+
+test iinfo-8.1 {info methods, simple case} -body {
+ type dog { }
+
+ dog spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {destroy info}
+
+test iinfo-8.2 {info methods, with pattern} -body {
+ type dog { }
+
+ dog spot
+
+ spot info methods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test iinfo-8.3 {info methods, with explicit methods} -body {
+ type dog {
+ method foo {} {}
+ delegate method bar to comp
+ }
+
+ dog spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {bar destroy foo info}
+
+test iinfo-8.4 {info methods, with implicit methods} -body {
+ type dog {
+ delegate method * to comp
+
+ constructor {args} {
+ set comp string
+ }
+ }
+
+ dog create spot
+
+ set a [lsort [spot info methods]]
+
+ spot length foo
+ spot is boolean yes
+
+ set b [lsort [spot info methods]]
+
+ set c [spot info methods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{destroy info} {destroy info is length} length}
+
+test iinfo-8.5 {info methods, with hierarchical methods} -body {
+ type dog {
+ delegate method {comp foo} to comp
+
+ method {comp bar} {} {}
+ }
+
+ dog create spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} destroy info}
+
+test iinfo-9.1 {info args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args bark
+} -cleanup {
+ dog destroy
+} -result {volume}
+
+test iinfo-9.2 {info args, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4]
+
+test iinfo-9.3 {info args, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}]
+
+test iinfo-9.4 {info args, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-9.5 {info args, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+test iinfo-10.1 {info default} -body {
+ type dog {
+ method bark {{volume 50}} {}
+ }
+
+ dog spot
+
+ list [spot info default bark volume def] $def
+} -cleanup {
+ dog destroy
+} -result {1 50}
+
+test iinfo-10.2 {info default, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info default
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4]
+
+test iinfo-10.3 {info default, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info default bark wag def foo
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}]
+
+test iinfo-10.4 {info default, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-10.5 {info default, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+test iinfo-11.1 {info body} -body {
+ type dog {
+ typevariable x
+ variable y
+ method bark {volume} {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+ }
+
+ dog spot
+
+ spot info body bark
+} -cleanup {
+ dog destroy
+} -result {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+
+test iinfo-11.2 {info body, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info body
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4]
+
+test iinfo-11.3 {info body, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info body bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}]
+
+test iinfo-11.4 {info body, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-11.5 {info body, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+#-----------------------------------------------------------------------
+# Type Introspection
+
+# Case 1
+test tinfo-1.1 {type info too few args} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1]
+
+# Case 2
+test tinfo-1.2 {type info too few args} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "dog info command ?arg ...?"} \
+ {wrong # args: should be "dog info command ..."}]
+
+test tinfo-1.3 {type info too many args} -body {
+ type dog { }
+
+ dog info instances foo bar
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}]
+
+test tinfo-2.1 {type info typevars} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ lsort [dog info typevars]
+} -cleanup {
+ dog destroy
+} -result {::dog::thatvar ::dog::thisvar}
+
+test tinfo-3.1 {type info instances} -body {
+ type dog { }
+
+ dog create spot
+ dog create fido
+
+ lsort [dog info instances]
+} -cleanup {
+ dog destroy
+} -result {::fido ::spot}
+
+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 tinfo-3.3 {type info instances with non-global namespaces} -body {
+ type dog { }
+
+ dog create ::spot
+
+ namespace eval ::dogs:: {
+ set ::qname [dog create fido]
+ }
+
+ list $qname [lsort [dog info instances]]
+} -cleanup {
+ dog destroy
+} -result {::dogs::fido {::dogs::fido ::spot}}
+
+test tinfo-3.4 {type info instances with pattern} -body {
+ type dog { }
+
+ dog create spot
+ dog create fido
+
+ dog info instances "*f*"
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body {
+ type dog { }
+ namespace eval dog::unrelated {}
+ dog create fido
+
+ dog info instances
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+test tinfo-4.1 {type info typevars with pattern} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ dog info typevars *this*
+} -cleanup {
+ dog destroy
+} -result {::dog::thisvar}
+
+test tinfo-5.1 {type info typemethods, simple case} -body {
+ type dog { }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {create destroy info}
+
+test tinfo-5.2 {type info typemethods, with pattern} -body {
+ type dog { }
+
+ dog info typemethods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test tinfo-5.3 {type info typemethods, with explicit typemethods} -body {
+ type dog {
+ typemethod foo {} {}
+ delegate typemethod bar to comp
+ }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {bar create destroy foo info}
+
+test tinfo-5.4 {type info typemethods, with implicit typemethods} -body {
+ type dog {
+ delegate typemethod * to comp
+
+ typeconstructor {
+ set comp string
+ }
+ }
+
+ set a [lsort [dog info typemethods]]
+
+ dog length foo
+ dog is boolean yes
+
+ set b [lsort [dog info typemethods]]
+
+ set c [dog info typemethods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{create destroy info} {create destroy info is length} length}
+
+test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body {
+ type dog {
+ delegate typemethod {comp foo} to comp
+
+ typemethod {comp bar} {} {}
+ }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} create destroy info}
+
+test tinfo-6.1 {type info args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args bark
+} -cleanup {
+ dog destroy
+} -result {volume}
+
+test tinfo-6.2 {type info args, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1]
+
+test tinfo-6.3 {type info args, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}]
+
+test tinfo-6.4 {type info args, unknown method} -body {
+ type dog {
+ }
+
+ dog info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-6.5 {type info args, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+test tinfo-7.1 {type info default} -body {
+ type dog {
+ typemethod bark {{volume 50}} {}
+ }
+
+ list [dog info default bark volume def] $def
+} -cleanup {
+ dog destroy
+} -result {1 50}
+
+test tinfo-7.2 {type info default, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info default
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1]
+
+test tinfo-7.3 {type info default, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info default bark wag def foo
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}]
+
+test tinfo-7.4 {type info default, unknown method} -body {
+ type dog {
+ }
+
+ dog info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-7.5 {type info default, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+test tinfo-8.1 {type info body} -body {
+ type dog {
+ typevariable x
+ variable y
+ typemethod bark {volume} {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+ }
+
+ dog info body bark
+} -cleanup {
+ dog destroy
+} -result {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+
+test tinfo-8.2 {type info body, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info body
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1]
+
+test tinfo-8.3 {type info body, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info body bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}]
+
+test tinfo-8.4 {type info body, unknown method} -body {
+ type dog {
+ }
+
+ dog info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-8.5 {type info body, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+#-----------------------------------------------------------------------
+# Setting the widget class explicitly
+
+test widgetclass-1.1 {can't set widgetclass for snit::types} -body {
+ type dog {
+ widgetclass Dog
+ }
+} -returnCodes {
+ error
+} -result {widgetclass cannot be set for snit::types}
+
+test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints {
+ tk
+} -body {
+ widgetadaptor dog {
+ widgetclass Dog
+ }
+} -returnCodes {
+ error
+} -result {widgetclass cannot be set for snit::widgetadaptors}
+
+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 {} {
+ $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 green
+ }
+
+ method background {} {
+ $hull cget -background
+ }
+ }
+
+ dog .dog
+
+ set bg [.dog background]
+
+ destroy .dog
+
+ set bg
+} -cleanup {
+ dog destroy
+} -result {green}
+
+#-----------------------------------------------------------------------
+# hulltype statement
+
+test hulltype-1.1 {can't set hulltype for snit::types} -body {
+ type dog {
+ hulltype Dog
+ }
+} -returnCodes {
+ error
+} -result {hulltype cannot be set for snit::types}
+
+test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints {
+ tk
+} -body {
+ widgetadaptor dog {
+ hulltype Dog
+ }
+} -returnCodes {
+ error
+} -result {hulltype cannot be set for snit::widgetadaptors}
+
+test hulltype-1.3 {hulltype can be frame} -constraints {
+ tk
+} -body {
+ widget dog {
+ delegate option * to 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 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 {
+ lsort $::snit::hulltypes
+} -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe}
+
+
+#-----------------------------------------------------------------------
+# expose statement
+
+test expose-1.1 {can't expose nothing} -body {
+ type dog {
+ expose
+ }
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0]
+
+test expose-1.1a {can't expose nothing} -body {
+ type dog {
+ expose
+ }
+} -constraints {
+ snit2
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0]
+
+test expose-1.2 {expose a component that's never installed} -body {
+ type dog {
+ expose tail
+ }
+
+ dog fido
+
+ fido tail wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {undefined component "tail"}
+
+test expose-1.3 {exposed method returns component command} -body {
+ type tail { }
+
+ type dog {
+ expose tail
+
+ constructor {} {
+ install tail using tail $self.tail
+ }
+
+ destructor {
+ $tail destroy
+ }
+ }
+
+ dog fido
+
+ fido tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {::fido.tail}
+
+test expose-1.4 {exposed method calls component methods} -body {
+ type tail {
+ method wag {args} {return "wag<$args>"}
+ method droop {} {return "droop"}
+ }
+
+ type dog {
+ expose tail
+
+ constructor {} {
+ install tail using tail $self.tail
+ }
+
+ destructor {
+ $tail destroy
+ }
+ }
+
+ dog fido
+
+ list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \
+ [fido tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wag<> wag<abc> {wag<abc def>} droop}
+
+#-----------------------------------------------------------------------
+# Error handling
+#
+# This section verifies that errorInfo and errorCode are propagated
+# appropriately on error.
+
+test error-1.1 {typemethod errors propagate properly} -body {
+ type dog {
+ typemethod generr {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.2 {snit::type constructor errors propagate properly} -body {
+ type dog {
+ constructor {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog fido} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {{Error in constructor: bogusError} 1 bogusCode}
+
+test error-1.3 {snit::widget constructor errors propagate properly} -constraints {
+ tk
+} -body {
+ widget dog {
+ constructor {args} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog .fido} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {{Error in constructor: bogusError} 1 bogusCode}
+
+test error-1.4 {method errors propagate properly} -body {
+ type dog {
+ method generr {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.5 {onconfigure errors propagate properly} -body {
+ type dog {
+ option -generr
+
+ onconfigure -generr {value} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido configure -generr 0} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.6 {oncget errors propagate properly} -body {
+ type dog {
+ option -generr
+
+ oncget -generr {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido cget -generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+#-----------------------------------------------------------------------
+# Externally defined typemethods
+
+test etypemethod-1.1 {external typemethods can be called as expected} -body {
+ type dog { }
+ typemethod dog foo {a} {return "+$a+"}
+
+ dog foo bar
+} -cleanup {
+ dog destroy
+} -result {+bar+}
+
+test etypemethod-1.2 {external typemethods can use typevariables} -body {
+ type dog {
+ typevariable somevar "Howdy"
+ }
+ typemethod dog getvar {} {return $somevar}
+
+ dog getvar
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test etypemethod-1.3 {typemethods can be redefined dynamically} -body {
+ type dog {
+ typemethod foo {} { return "foo" }
+ }
+ set a [dog foo]
+
+ typemethod dog foo {} { return "bar"}
+
+ set b [dog foo]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {foo bar}
+
+test etypemethod-1.4 {can't define external typemethod if no type} -body {
+ typemethod extremelyraredog foo {} { return "bar"}
+} -returnCodes {
+ error
+} -result {no such type: "extremelyraredog"}
+
+test etypemethod-2.1 {external hierarchical method, two tokens} -body {
+ type dog { }
+ typemethod dog {wag tail} {} {
+ return "wags tail"
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail}
+
+test etypemethod-2.2 {external hierarchical method, three tokens} -body {
+ type dog { }
+ typemethod dog {wag tail proudly} {} {
+ return "wags tail proudly"
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {wags tail proudly}
+
+test etypemethod-2.3 {external hierarchical method, three tokens} -body {
+ type dog { }
+ typemethod dog {wag tail really high} {} {
+ return "wags tail really high"
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+} -result {wags tail really high}
+
+test etypemethod-2.4 {redefinition is OK} -body {
+ type dog { }
+ typemethod dog {wag tail} {} {
+ return "wags tail"
+ }
+ typemethod dog {wag tail} {} {
+ return "wags tail briskly"
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail briskly}
+
+test etypemethod-3.1 {prefix/method collision} -body {
+ type dog {
+ typemethod wag {} {}
+ }
+
+ typemethod dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag" has no submethods.}
+
+test etypemethod-3.2 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ }
+
+ typemethod dog wag {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag", "wag" has submethods.}
+
+test etypemethod-3.3 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ }
+
+ typemethod dog {wag tail proudly} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
+
+test etypemethod-3.4 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {}
+ }
+
+ typemethod dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# Externally defined methods
+
+test emethod-1.1 {external methods can be called as expected} -body {
+ type dog { }
+ method dog bark {a} {return "+$a+"}
+
+ dog spot
+ spot bark woof
+} -cleanup {
+ dog destroy
+} -result {+woof+}
+
+test emethod-1.2 {external methods can use typevariables} -body {
+ type dog {
+ typevariable somevar "Hello"
+ }
+ method dog getvar {} {return $somevar}
+
+ dog spot
+ spot getvar
+} -cleanup {
+ dog destroy
+} -result {Hello}
+
+test emethod-1.3 {external methods can use variables} -body {
+ type dog {
+ variable somevar "Greetings"
+ }
+ method dog getvar {} {return $somevar}
+
+ dog spot
+ spot getvar
+} -cleanup {
+ dog destroy
+} -result {Greetings}
+
+test emethod-1.4 {methods can be redefined dynamically} -body {
+ type dog {
+ method bark {} { return "woof" }
+ }
+
+ dog spot
+
+ set a [spot bark]
+
+ method dog bark {} { return "arf"}
+
+ set b [spot bark]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {woof arf}
+
+test emethod-1.5 {delegated methods can't be redefined} -body {
+ type dog {
+ delegate method bark to someotherdog
+ }
+
+ method dog bark {} { return "arf"}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "bark", "bark" has been delegated}
+
+test emethod-1.6 {can't define external method if no type} -body {
+ method extremelyraredog foo {} { return "bar"}
+} -returnCodes {
+ error
+} -result {no such type: "extremelyraredog"}
+
+test emethod-2.1 {external hierarchical method, two tokens} -body {
+ type dog { }
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail.}
+
+test emethod-2.2 {external hierarchical method, three tokens} -body {
+ type dog { }
+ method dog {wag tail proudly} {} {
+ return "$self wags tail proudly."
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail proudly.}
+
+test emethod-2.3 {external hierarchical method, three tokens} -body {
+ type dog { }
+ method dog {wag tail really high} {} {
+ return "$self wags tail really high."
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail really high.}
+
+test emethod-2.4 {redefinition is OK} -body {
+ type dog { }
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+ method dog {wag tail} {} {
+ return "$self wags tail briskly."
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail briskly.}
+
+test emethod-3.1 {prefix/method collision} -body {
+ type dog {
+ method wag {} {}
+ }
+
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag" has no submethods.}
+
+test emethod-3.2 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+
+ method dog wag {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag", "wag" has submethods.}
+
+test emethod-3.3 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {}
+ }
+
+ method dog {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
+
+test emethod-3.4 {prefix/method collision} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ }
+
+ method dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag tail" has submethods.}
+
+
+#-----------------------------------------------------------------------
+# Macros
+
+test macro-1.1 {can't redefine non-macros} -body {
+ snit::macro method {} {}
+} -returnCodes {
+ error
+} -result {invalid macro name "method"}
+
+test macro-1.2 {can define and use a macro} -body {
+ snit::macro hello {name} {
+ method hello {} "return {Hello, $name!}"
+ }
+
+ type dog {
+ hello World
+ }
+
+ dog spot
+
+ spot hello
+
+} -cleanup {
+ dog destroy
+} -result {Hello, World!}
+
+test macro-1.3 {can redefine macro} -body {
+ snit::macro dup {} {}
+ snit::macro dup {} {}
+
+ set dummy "No error"
+} -result {No error}
+
+test macro-1.4 {can define macro in namespace} -body {
+ snit::macro ::test::goodbye {name} {
+ method goodbye {} "return {Goodbye, $name!}"
+ }
+
+ type dog {
+ ::test::goodbye World
+ }
+
+ dog spot
+
+ spot goodbye
+} -cleanup {
+ dog destroy
+} -result {Goodbye, World!}
+
+test macro-1.5 {_proc and _variable are defined} -body {
+ snit::macro testit {} {
+ set a [info commands _variable]
+ set b [info commands _proc]
+ method testit {} "list $a $b"
+ }
+
+ type dog {
+ testit
+ }
+
+ dog spot
+
+ spot testit
+} -cleanup {
+ dog destroy
+} -result {_variable _proc}
+
+test macro-1.6 {_variable works} -body {
+ snit::macro test1 {} {
+ _variable myvar "_variable works"
+ }
+
+ snit::macro test2 {} {
+ _variable myvar
+
+ method testit {} "return {$myvar}"
+ }
+
+ type dog {
+ test1
+ test2
+ }
+
+ dog spot
+
+ spot testit
+} -cleanup {
+ dog destroy
+} -result {_variable works}
+
+#-----------------------------------------------------------------------
+# Component Statement
+
+test component-1.1 {component defines an instance variable} -body {
+ type dog {
+ component tail
+ }
+
+ dog spot
+
+ namespace tail [spot info vars tail]
+} -cleanup {
+ dog destroy
+} -result {tail}
+
+test component-1.2 {-public exposes the component} -body {
+ type tail {
+ method wag {} {
+ return "Wag, wag"
+ }
+ }
+
+ type dog {
+ component tail -public mytail
+
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot mytail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {Wag, wag}
+
+test component-1.3 {-inherit requires a boolean value} -body {
+ type dog {
+ component animal -inherit foo
+ }
+} -returnCodes {
+ error
+} -result {component animal -inherit: expected boolean value, got "foo"}
+
+test component-1.4 {-inherit delegates unknown methods to the component} -body {
+ type animal {
+ method eat {} {
+ return "Eat, eat."
+ }
+ }
+
+ type dog {
+ component animal -inherit yes
+
+ constructor {} {
+ set animal [animal %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot eat
+} -cleanup {
+ dog destroy
+ animal destroy
+} -result {Eat, eat.}
+
+test component-1.5 {-inherit delegates unknown options to the component} -body {
+ type animal {
+ option -size medium
+ }
+
+ type dog {
+ component animal -inherit yes
+
+ constructor {} {
+ set animal [animal %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot cget -size
+} -cleanup {
+ dog destroy
+ animal destroy
+} -result {medium}
+
+#-----------------------------------------------------------------------
+# Typevariables, Variables, Typecomponents, Components
+
+test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body {
+ type dog {
+ typevariable var
+ variable var
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable var...", "var" is already a typevariable}
+
+test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body {
+ type dog {
+ variable var
+ typevariable var
+ }
+} -returnCodes {
+ error
+} -result {Error in "typevariable var...", "var" is already an instance variable}
+
+test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body {
+ type dog {
+ typecomponent comp
+ component comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "component comp...", "comp" is already a typevariable}
+
+test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body {
+ type dog {
+ component comp
+ typecomponent comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "typecomponent comp...", "comp" is already an instance variable}
+
+test typevar_var-1.5 {can't delegate options to typecomponents} -body {
+ type dog {
+ typecomponent comp
+
+ delegate option -opt to comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option -opt...", "comp" is already a typevariable}
+
+test typevar_var-1.6 {can't delegate typemethods to instance components} -body {
+ type dog {
+ component comp
+
+ delegate typemethod foo to comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod foo...", "comp" is already an instance variable}
+
+test typevar_var-1.7 {can delegate methods to typecomponents} -body {
+ proc echo {args} {return [join $args "|"]}
+
+ type dog {
+ typecomponent tail
+
+ typeconstructor {
+ set tail echo
+ }
+
+ delegate method wag to tail
+ }
+
+ dog spot
+ spot wag briskly
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {wag|briskly}
+
+#-----------------------------------------------------------------------
+# Option syntax tests.
+#
+# This set of tests verifies that the option statement is interpreted
+# properly, that errors are caught, and that the type's optionInfo
+# array is initialized properly.
+#
+# TBD: At some point, this needs to be folded into the regular
+# option tests.
+
+test optionsyntax-1.1 {local option names are saved} -body {
+ type dog {
+ option -foo
+ option -bar
+ }
+
+ set ::dog::Snit_optionInfo(local)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar}
+
+test optionsyntax-1.2 {islocal flag is set} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(islocal--foo)
+} -cleanup {
+ dog destroy
+} -result {1}
+
+test optionsyntax-2.1 {implicit resource and class} -body {
+ type dog {
+ option -foo
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {foo Foo}
+
+test optionsyntax-2.2 {explicit resource, default class} -body {
+ type dog {
+ option {-foo ffoo}
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo Ffoo}
+
+test optionsyntax-2.3 {explicit resource and class} -body {
+ type dog {
+ option {-foo ffoo FFoo}
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo FFoo}
+
+test optionsyntax-2.4 {can't redefine explicit resource} -body {
+ type dog {
+ option {-foo ffoo}
+ option {-foo foo}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}
+
+test optionsyntax-2.5 {can't redefine explicit class} -body {
+ type dog {
+ option {-foo ffoo Ffoo}
+ option {-foo ffoo FFoo}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}
+
+test optionsyntax-2.6 {can redefine implicit resource and class} -body {
+ type dog {
+ option -foo
+ option {-foo ffoo}
+ option {-foo ffoo FFoo}
+ option -foo
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test optionsyntax-3.1 {no default value} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(default--foo)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test optionsyntax-3.2 {default value, old syntax} -body {
+ type dog {
+ option -foo bar
+ }
+
+ set ::dog::Snit_optionInfo(default--foo)
+} -cleanup {
+ dog destroy
+} -result {bar}
+
+test optionsyntax-3.3 {option definition options can be set} -body {
+ type dog {
+ option -foo \
+ -default Bar \
+ -validatemethod Validate \
+ -configuremethod Configure \
+ -cgetmethod Cget \
+ -readonly 1
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar Validate Configure Cget 1}
+
+test optionsyntax-3.4 {option definition option values accumulate} -body {
+ type dog {
+ option -foo -default Bar
+ option -foo -validatemethod Validate
+ option -foo -configuremethod Configure
+ option -foo -cgetmethod Cget
+ option -foo -readonly 1
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar Validate Configure Cget 1}
+
+test optionsyntax-3.5 {option definition option values can be redefined} -body {
+ type dog {
+ option -foo -default Bar
+ option -foo -validatemethod Validate
+ option -foo -configuremethod Configure
+ option -foo -cgetmethod Cget
+ option -foo -readonly 1
+ option -foo -default Bar2
+ option -foo -validatemethod Validate2
+ option -foo -configuremethod Configure2
+ option -foo -cgetmethod Cget2
+ option -foo -readonly 0
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar2 Validate2 Configure2 Cget2 0}
+
+test optionsyntax-3.6 {option -readonly defaults to 0} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test optionsyntax-3.7 {option -readonly can be any boolean} -body {
+ type dog {
+ option -foo -readonly 0
+ option -foo -readonly 1
+ option -foo -readonly y
+ option -foo -readonly n
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test optionsyntax-3.8 {option -readonly must be a boolean} -body {
+ type dog {
+ option -foo -readonly foo
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -foo...", -readonly requires a boolean, got "foo"}
+
+test optionsyntax-3.9 {option -readonly can't be empty} -body {
+ type dog {
+ option -foo -readonly {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -foo...", -readonly requires a boolean, got ""}
+
+#-----------------------------------------------------------------------
+# 'delegate option' Syntax tests.
+#
+# This set of tests verifies that the 'delegation option' statement is
+# interpreted properly, and that the type's optionInfo
+# array is initialized properly.
+#
+# TBD: At some point, this needs to be folded into the regular
+# option tests.
+
+test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body {
+ type dog {
+ delegate option -foo to comp
+ delegate option -bar to comp
+ }
+
+ set ::dog::Snit_optionInfo(delegated)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar}
+
+test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ set ::dog::Snit_optionInfo(delegated)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(islocal--foo)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ info exists ::dog::Snit_optionInfo(islocal-*)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body {
+ type dog {
+ delegate option -foo to comp1
+ delegate option -bar to comp1
+ delegate option -baz to comp2
+
+ # The * won't show up.
+ delegate option * to comp2
+ }
+
+ list \
+ $::dog::Snit_optionInfo(delegated-comp1) \
+ $::dog::Snit_optionInfo(delegated-comp2)
+} -cleanup {
+ dog destroy
+} -result {{-foo -bar} -baz}
+
+test delegateoptionsyntax-1.6 {'except' is empty by default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(except)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.7 {'except' lists exceptions} -body {
+ type dog {
+ delegate option * to comp except {-foo -bar -baz}
+ }
+
+ set ::dog::Snit_optionInfo(except)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar -baz}
+
+test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(target--foo)
+} -cleanup {
+ dog destroy
+} -result {comp -foo}
+
+test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body {
+ type dog {
+ delegate option -foo to comp as -bar
+ }
+
+ set ::dog::Snit_optionInfo(target--foo)
+} -cleanup {
+ dog destroy
+} -result {comp -bar}
+
+test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(starcomp)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.11 {'starcomp' set for *} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ set ::dog::Snit_optionInfo(starcomp)
+} -cleanup {
+ dog destroy
+} -result {comp}
+
+test delegatedoptionsyntax-2.1 {implicit resource and class} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {foo Foo}
+
+test delegatedoptionsyntax-2.2 {explicit resource, default class} -body {
+ type dog {
+ delegate option {-foo ffoo} to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo Ffoo}
+
+test delegatedoptionsyntax-2.3 {explicit resource and class} -body {
+ type dog {
+ delegate option {-foo ffoo FFoo} to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo FFoo}
+
+test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ list \
+ [info exist ::dog::Snit_optionInfo(resource-*)] \
+ [info exist ::dog::Snit_optionInfo(class-*)]
+} -cleanup {
+ dog destroy
+} -result {0 0}
+
+#-----------------------------------------------------------------------
+# Cget cache
+
+test cgetcache-1.1 {Instance rename invalidates cache} -body {
+ type dog {
+ option -foo -default bar -cgetmethod getfoo
+
+ method getfoo {option} {
+ return $options($option)
+ }
+ }
+
+ dog fido -foo quux
+
+ # Cache the cget command.
+ fido cget -foo
+
+ rename fido spot
+
+ spot cget -foo
+} -cleanup {
+ dog destroy
+} -result {quux}
+
+test cgetcache-1.2 {Component rename invalidates cache} -body {
+ type tail {
+ option -foo bar
+ }
+
+ type dog {
+ delegate option -foo to tail
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ $tail configure -foo quux
+ }
+
+ method retail {} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog fido
+
+ # Cache the cget command.
+ fido cget -foo
+
+ # Invalidate the cache
+ fido retail
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {bar}
+
+# case 1
+test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -cgetmethod bogus
+ }
+
+ dog fido -foo quux
+
+ fido cget -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't cget -foo, "::fido bogus" is not defined}
+
+# case 2
+test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -cgetmethod bogus
+ }
+
+ dog fido -foo quux
+
+ fido cget -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be cget, or configurelist}
+
+test cgetcache-1.5 {hierarchical -cgetmethod} -body {
+ type dog {
+ option -foo -default bar -cgetmethod {Get Opt}
+
+ method {Get Opt} {option} {
+ return Dummy
+ }
+ }
+
+ dog fido
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+} -result {Dummy}
+
+#-----------------------------------------------------------------------
+# Configure cache
+
+test configurecache-1.1 {Instance rename invalidates cache} -body {
+ type dog {
+ option -foo -default bar -configuremethod setfoo
+
+ method setfoo {option value} {
+ $self setoption $option $value
+ }
+
+ method setoption {option value} {
+ set options($option) $value
+ }
+ }
+
+ # Set the option on creation; this will cache the
+ # configure command.
+ dog fido -foo quux
+
+ rename fido spot
+
+ spot configure -foo baz
+ spot cget -foo
+} -cleanup {
+ dog destroy
+} -result {baz}
+
+test configurecache-1.2 {Component rename invalidates cache} -body {
+ type tail {
+ option -foo bar
+ }
+
+ type dog {
+ delegate option -foo to tail
+
+ constructor {args} {
+ set tail [tail thistail]
+ $self configurelist $args
+ }
+
+ method retail {} {
+ # Give it a new component
+ set tail [tail thattail]
+ }
+ }
+
+ # Set the tail's -foo, and cache the command.
+ dog fido -foo quux
+
+ # Invalidate the cache
+ fido retail
+
+ # Should recache, and set the new tail's option.
+ fido configure -foo baz
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {baz}
+
+# Case 1
+test configurecache-1.3 {Invalid -configuremethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -configuremethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't configure -foo, "::fido bogus" is not defined}
+
+# Case 2
+test configurecache-1.4 {Invalid -configuremethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -configuremethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be configure, or configurelist}
+
+test configurecache-1.5 {hierarchical -configuremethod} -body {
+ type dog {
+ option -foo -default bar -configuremethod {Set Opt}
+
+ method {Set Opt} {option value} {
+ set options($option) Dummy
+ }
+ }
+
+ dog fido -foo NotDummy
+ fido cget -foo
+} -cleanup {
+ dog destroy
+} -result {Dummy}
+
+
+
+#-----------------------------------------------------------------------
+# 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}
+
+# Case 1
+test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -validatemethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't validate -foo, "::fido bogus" is not defined}
+
+# Case 2
+test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -validatemethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be configure, or configurelist}
+
+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 {Error in constructor: 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}
+
+#-----------------------------------------------------------------------
+# Pragma -hastypeinfo
+
+test hastypeinfo-1.1 {$type info is defined by default} -body {
+ type dog {
+ typevariable foo
+ }
+
+ dog info typevars
+} -cleanup {
+ dog destroy
+} -result {::dog::foo}
+
+# Case 1
+test hastypeinfo-1.2 {$type info can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hastypeinfo no
+ typevariable foo
+ }
+
+ dog info typevars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog info" is not defined}
+
+# Case 2
+test hastypeinfo-1.3 {$type info can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hastypeinfo no
+ typevariable foo
+ }
+
+ dog info typevars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "info": namespace ::dog does not export any commands}
+
+
+#-----------------------------------------------------------------------
+# Pragma -hastypedestroy
+
+test hastypedestroy-1.1 {$type destroy is defined by default} -body {
+ type dog {
+ typevariable foo
+ }
+
+ dog destroy
+
+ ::dog info typevars
+} -returnCodes {
+ error
+} -result {invalid command name "::dog"}
+
+# Case 1
+test hastypedestroy-1.2 {$type destroy can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hastypedestroy no
+ typevariable foo
+ }
+
+ dog destroy
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {"::dog destroy" is not defined}
+
+# Case 2
+test hastypedestroy-1.3 {$type destroy can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hastypedestroy no
+ typevariable foo
+ }
+
+ dog destroy
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {unknown subcommand "destroy": namespace ::dog does not export any commands}
+
+#-----------------------------------------------------------------------
+# Pragma -hasinstances
+
+test hasinstances-1.1 {-hasinstances is true by default} -body {
+ type dog {
+ method bark {} {
+ return "Woof"
+ }
+ }
+
+ dog fido
+ fido bark
+} -cleanup {
+ dog destroy
+} -result {Woof}
+
+# Case 1
+test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog create fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog create" is not defined}
+
+# Case 2
+test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog create fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "create": namespace ::dog does not export any commands}
+
+# Case 1
+test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog fido
+} -returnCodes {
+ error
+} -result {"::dog fido" is not defined}
+
+# Case 2
+test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog fido
+} -returnCodes {
+ error
+} -result {unknown subcommand "fido": namespace ::dog does not export any commands}
+
+#-----------------------------------------------------------------------
+# pragma -canreplace
+
+test canreplace-1.1 {By default, "-canreplace no"} -body {
+ type dog {
+ # ...
+ }
+
+ dog fido
+ dog fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {command "::fido" already exists}
+
+test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints {
+ bug8.5a3
+} -body {
+ type dog {
+ pragma -canreplace yes
+ }
+
+ dog fido
+ dog fido
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+#-----------------------------------------------------------------------
+# pragma -hasinfo
+
+test hasinfo-1.1 {$obj info is defined by default} -body {
+ type dog {
+ variable foo ""
+ }
+
+ dog spot
+ spot info vars
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::foo}
+
+# Case 1
+test hasinfo-1.2 {$obj info can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinfo no
+ variable foo
+ }
+
+ dog spot
+ spot info vars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::spot info" is not defined}
+
+# Case 2
+test hasinfo-1.3 {$obj info can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinfo no
+ variable foo
+ }
+
+ dog spot
+ spot info vars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands}
+
+#-----------------------------------------------------------------------
+# pragma -hastypemethods
+#
+# The "-hastypemethods yes" case is tested by the bulk of this file.
+# We'll test the "-hastypemethods no" case here.
+
+test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog spot
+} -cleanup {
+ spot destroy
+ rename ::dog ""
+ namespace delete ::dog
+} -result {::spot}
+
+test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog create spot
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
+
+test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {command "::info" already exists}
+
+test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints {
+ tk
+} -body {
+ widget dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {wrong # args: should be "::dog name args"}
+
+test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ pragma -hasinstances no
+ variable foo
+ }
+} -returnCodes {
+ error
+} -result {type ::dog has neither typemethods nor instances}
+
+#-----------------------------------------------------------------------
+# -simpledispatch yes
+
+test simpledispatch-1.1 {not allowed with method delegation.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ delegate method foo to bar
+ }
+} -returnCodes {
+ error
+} -result {type ::dog requests -simpledispatch but delegates methods.}
+
+test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ method barks {how} {
+ return "$self barks $how."
+ }
+ }
+
+ dog spot
+ spot barks loudly
+} -cleanup {
+ dog destroy
+} -result {::spot barks loudly.}
+
+test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+ set a [spot cget -breed]
+ spot configure -breed collie
+ set b [spot cget -breed]
+ spot configurelist [list -breed sheltie]
+ set c [spot cget -breed]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {mutt collie sheltie}
+
+test simpledispatch-1.4 {info method works with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+
+ spot info options
+} -cleanup {
+ dog destroy
+} -result {-breed}
+
+test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+ set a [info commands ::spot]
+ spot destroy
+ set b [info commands ::spot]
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {::spot {}}
+
+test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ method {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {type ::dog requests -simpledispatch but defines hierarchical methods.}
+
+#-----------------------------------------------------------------------
+# Exotic return codes
+
+test break-1.1 {Methods can "return -code break"} -body {
+ snit::type dog {
+ method bark {} {return -code break "Breaking"}
+ }
+
+ dog spot
+
+ catch {spot bark} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test break-1.2 {Typemethods can "return -code break"} -body {
+ snit::type dog {
+ typemethod bark {} {return -code break "Breaking"}
+ }
+
+ catch {dog bark} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test break-1.3 {Methods called via mymethod "return -code break"} -body {
+ snit::type dog {
+ method bark {} {return -code break "Breaking"}
+
+ method getbark {} {
+ return [mymethod bark]
+ }
+ }
+
+ dog spot
+
+ catch {uplevel \#0 [spot getbark]} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+#-----------------------------------------------------------------------
+# Namespace path
+
+test nspath-1.1 {Typemethods call commands from parent namespace} -constraints {
+ snit2
+} -body {
+ namespace eval ::snit_test:: {
+ proc bark {} {return "[namespace current]: Woof"}
+ }
+
+ snit::type ::snit_test::dog {
+ typemethod bark {} {
+ bark
+ }
+ }
+
+ ::snit_test::dog bark
+} -cleanup {
+ ::snit_test::dog destroy
+ namespace forget ::snit_test
+} -result {::snit_test: Woof}
+
+test nspath-1.2 {Methods can call commands from parent namespace} -constraints {
+ snit2
+} -body {
+ namespace eval ::snit_test:: {
+ proc bark {} {return "[namespace current]: Woof"}
+ }
+
+ snit::type ::snit_test::dog {
+ method bark {} {
+ bark
+ }
+ }
+
+ ::snit_test::dog spot
+ spot bark
+} -cleanup {
+ ::snit_test::dog destroy
+ namespace forget ::snit_test
+} -result {::snit_test: Woof}
+
+#-----------------------------------------------------------------------
+# snit::boolean
+
+test boolean-1.1 {boolean: valid} -body {
+ snit::boolean validate 1
+ snit::boolean validate 0
+ snit::boolean validate true
+ snit::boolean validate false
+ snit::boolean validate yes
+ snit::boolean validate no
+ snit::boolean validate on
+ snit::boolean validate off
+} -result {off}
+
+test boolean-1.2 {boolean: invalid} -body {
+ codecatch {snit::boolean validate quux}
+} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
+
+test boolean-2.1 {boolean subtype: valid} -body {
+ snit::boolean subtype
+ subtype validate 1
+ subtype validate 0
+ subtype validate true
+ subtype validate false
+ subtype validate yes
+ subtype validate no
+ subtype validate on
+ subtype validate off
+} -cleanup {
+ subtype destroy
+} -result {off}
+
+test boolean-2.2 {boolean subtype: invalid} -body {
+ snit::boolean subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
+
+#-----------------------------------------------------------------------
+# snit::double
+
+test double-1.1 {double: invalid -min} -body {
+ snit::double obj -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test double-1.2 {double: invalid -max} -body {
+ snit::double obj -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test double-1.3 {double: invalid, max < min} -body {
+ snit::double obj -min 5 -max 0
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test double-2.1 {double type: valid} -body {
+ snit::double validate 1.5
+} -result {1.5}
+
+test double-2.2 {double type: invalid} -body {
+ codecatch {snit::double validate abc}
+} -result {INVALID invalid value "abc", expected double}
+
+test double-3.1 {double subtype: valid, no range} -body {
+ snit::double subtype
+ subtype validate 1.5
+} -cleanup {
+ subtype destroy
+} -result {1.5}
+
+test double-3.2 {double subtype: valid, min but no max} -body {
+ snit::double subtype -min 0.5
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test double-3.3 {double subtype: valid, min and max} -body {
+ snit::double subtype -min 0.5 -max 10.5
+ subtype validate 1.5
+} -cleanup {
+ subtype destroy
+} -result {1.5}
+
+test double-4.1 {double subtype: not a number} -body {
+ snit::double subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", expected double}
+
+test double-4.2 {double subtype: less than min, no max} -body {
+ snit::double subtype -min 0.5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected double no less than 0.5}
+
+test double-4.3 {double subtype: less than min, with max} -body {
+ snit::double subtype -min 0.5 -max 5.5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected double in range 0.5, 5.5}
+
+test double-4.4 {double subtype: greater than max, no min} -body {
+ snit::double subtype -max 0.5
+ codecatch {subtype validate 1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "1", expected double no greater than 0.5}
+
+#-----------------------------------------------------------------------
+# snit::enum
+
+test enum-1.1 {enum: valid} -body {
+ snit::enum validate foo
+} -result {foo}
+
+test enum-2.1 {enum subtype: missing -values} -body {
+ snit::enum subtype
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -values: ""}
+
+test enum-3.1 {enum subtype: valid} -body {
+ snit::enum subtype -values {foo bar baz}
+ subtype validate foo
+ subtype validate bar
+ subtype validate baz
+} -cleanup {
+ subtype destroy
+} -result {baz}
+
+test enum-3.2 {enum subtype: invalid} -body {
+ snit::enum subtype -values {foo bar baz}
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", should be one of: foo, bar, baz}
+
+
+#-----------------------------------------------------------------------
+# snit::fpixels
+
+test fpixels-1.1 {no suffix} -constraints tk -body {
+ snit::fpixels validate 5
+} -result {5}
+
+test fpixels-1.2 {suffix} -constraints tk -body {
+ snit::fpixels validate 5i
+} -result {5i}
+
+test fpixels-1.3 {decimal} -constraints tk -body {
+ snit::fpixels validate 5.5
+} -result {5.5}
+
+test fpixels-1.4 {invalid} -constraints tk -body {
+ codecatch {snit::fpixels validate 5.5abc}
+} -result {INVALID invalid value "5.5abc", expected fpixels}
+
+test fpixels-2.1 {bad -min} -constraints tk -body {
+ snit::fpixels subtype -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test fpixels-2.2 {bad -max} -constraints tk -body {
+ snit::fpixels subtype -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test fpixels-2.3 {-min > -max} -constraints tk -body {
+ snit::fpixels subtype -min 10 -max 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test fpixels-3.1 {subtype, no suffix} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test fpixels-3.2 {suffix} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5i
+} -cleanup {
+ subtype destroy
+} -result {5i}
+
+test fpixels-3.3 {decimal} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5.5
+} -cleanup {
+ subtype destroy
+} -result {5.5}
+
+test fpixels-3.4 {invalid} -constraints tk -body {
+ snit::fpixels subtype
+ codecatch {subtype validate 5.5abc}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "5.5abc", expected fpixels}
+
+
+test fpixels-3.5 {subtype -min} -constraints tk -body {
+ snit::fpixels subtype -min 5
+ subtype validate 10
+} -cleanup {
+ subtype destroy
+} -result {10}
+
+test fpixels-3.6 {min of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test fpixels-3.7 {max of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 20
+} -cleanup {
+ subtype destroy
+} -result {20}
+
+test fpixels-3.8 {middle of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 15
+} -cleanup {
+ subtype destroy
+} -result {15}
+
+test fpixels-3.9 {invalid, < min} -constraints tk -body {
+ snit::fpixels subtype -min 5
+ codecatch {subtype validate 4}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "4", expected fpixels no less than 5}
+
+test fpixels-3.10 {invalid, > max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ codecatch {subtype validate 21}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "21", expected fpixels in range 5, 20}
+
+test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
+ snit::fpixels subtype -min 5i -max 10i
+ codecatch {subtype validate 11i}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i}
+
+#-----------------------------------------------------------------------
+# snit::integer
+
+test integer-1.1 {integer: invalid -min} -body {
+ snit::integer obj -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test integer-1.2 {integer: invalid -max} -body {
+ snit::integer obj -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test integer-1.3 {integer: invalid, max < min} -body {
+ snit::integer obj -min 5 -max 0
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test integer-2.1 {integer type: valid} -body {
+ snit::integer validate 1
+} -result {1}
+
+test integer-2.2 {integer type: invalid} -body {
+ codecatch {snit::integer validate abc}
+} -result {INVALID invalid value "abc", expected integer}
+
+test integer-3.1 {integer subtype: valid, no range} -body {
+ snit::integer subtype
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-3.2 {integer subtype: valid, min but no max} -body {
+ snit::integer subtype -min 0
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-3.3 {integer subtype: valid, min and max} -body {
+ snit::integer subtype -min 0 -max 10
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-4.1 {integer subtype: not a number} -body {
+ snit::integer subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", expected integer}
+
+test integer-4.2 {integer subtype: less than min, no max} -body {
+ snit::integer subtype -min 0
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected integer no less than 0}
+
+test integer-4.3 {integer subtype: less than min, with max} -body {
+ snit::integer subtype -min 0 -max 5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected integer in range 0, 5}
+
+#-----------------------------------------------------------------------
+# snit::listtype
+
+test listtype-1.1 {listtype, length 0; valid} -body {
+ snit::listtype validate ""
+} -result {}
+
+test listtype-1.2 {listtype, length 1; valid} -body {
+ snit::listtype validate a
+} -result {a}
+
+test listtype-1.3 {listtype, length 2; valid} -body {
+ snit::listtype validate {a b}
+} -result {a b}
+
+test listtype-2.1 {listtype subtype, length 0; valid} -body {
+ snit::listtype subtype
+ subtype validate ""
+} -cleanup {
+ subtype destroy
+} -result {}
+
+test listtype-2.2 {listtype, length 1; valid} -body {
+ snit::listtype subtype
+ subtype validate a
+} -cleanup {
+ subtype destroy
+} -result {a}
+
+test listtype-2.3 {listtype, length 2; valid} -body {
+ snit::listtype subtype
+ subtype validate {a b}
+} -cleanup {
+ subtype destroy
+} -result {a b}
+
+test listtype-2.4 {listtype, invalid -minlen} -body {
+ snit::listtype subtype -minlen abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "abc"}
+
+test listtype-2.5 {listtype, negative -minlen} -body {
+ snit::listtype subtype -minlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "-1"}
+
+test listtype-2.6 {listtype, invalid -maxlen} -body {
+ snit::listtype subtype -maxlen abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -maxlen: "abc"}
+
+test listtype-2.7 {listtype, -maxlen < -minlen} -body {
+ snit::listtype subtype -minlen 10 -maxlen 9
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test listtype-3.1 {-minlen 2, length 2; valid} -body {
+ snit::listtype subtype -minlen 2
+ subtype validate {a b}
+} -cleanup {
+ subtype destroy
+} -result {a b}
+
+test listtype-3.2 {-minlen 2, length 3; valid} -body {
+ snit::listtype subtype -minlen 2
+ subtype validate {a b c}
+} -cleanup {
+ subtype destroy
+} -result {a b c}
+
+test listtype-3.3 {-minlen 2, length 1; invalid} -body {
+ snit::listtype subtype -minlen 2
+ codecatch {subtype validate a}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too few elements; at least 2 expected}
+
+test listtype-3.4 {range 1 to 3, length 1; valid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ subtype validate a
+} -cleanup {
+ subtype destroy
+} -result {a}
+
+test listtype-3.5 {range 1 to 3, length 3; valid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ subtype validate {a b c}
+} -cleanup {
+ subtype destroy
+} -result {a b c}
+
+test listtype-3.6 {range 1 to 3, length 0; invalid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ codecatch {subtype validate {}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too few elements; at least 1 expected}
+
+test listtype-3.7 {range 1 to 3, length 4; invalid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ codecatch {subtype validate {a b c d}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too many elements; no more than 3 expected}
+
+test listtype-4.1 {boolean list, valid} -body {
+ snit::listtype subtype -type snit::boolean
+ subtype validate {yes 1 true}
+} -cleanup {
+ subtype destroy
+} -result {yes 1 true}
+
+test listtype-4.2 {boolean list, invalid} -body {
+ snit::listtype subtype -type snit::boolean
+ codecatch {subtype validate {yes 1 abc no}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off}
+
+#-----------------------------------------------------------------------
+# snit::pixels
+
+test pixels-1.1 {no suffix} -constraints tk -body {
+ snit::pixels validate 5
+} -result {5}
+
+test pixels-1.2 {suffix} -constraints tk -body {
+ snit::pixels validate 5i
+} -result {5i}
+
+test pixels-1.3 {decimal} -constraints tk -body {
+ snit::pixels validate 5.5
+} -result {5.5}
+
+test pixels-1.4 {invalid} -constraints tk -body {
+ codecatch {snit::pixels validate 5.5abc}
+} -result {INVALID invalid value "5.5abc", expected pixels}
+
+test pixels-2.1 {bad -min} -constraints tk -body {
+ snit::pixels subtype -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test pixels-2.2 {bad -max} -constraints tk -body {
+ snit::pixels subtype -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test pixels-2.3 {-min > -max} -constraints tk -body {
+ snit::pixels subtype -min 10 -max 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test pixels-3.1 {subtype, no suffix} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test pixels-3.2 {suffix} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5i
+} -cleanup {
+ subtype destroy
+} -result {5i}
+
+test pixels-3.3 {decimal} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5.5
+} -cleanup {
+ subtype destroy
+} -result {5.5}
+
+test pixels-3.4 {invalid} -constraints tk -body {
+ snit::pixels subtype
+ codecatch {subtype validate 5.5abc}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "5.5abc", expected pixels}
+
+
+test pixels-3.5 {subtype -min} -constraints tk -body {
+ snit::pixels subtype -min 5
+ subtype validate 10
+} -cleanup {
+ subtype destroy
+} -result {10}
+
+test pixels-3.6 {min of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test pixels-3.7 {max of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 20
+} -cleanup {
+ subtype destroy
+} -result {20}
+
+test pixels-3.8 {middle of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 15
+} -cleanup {
+ subtype destroy
+} -result {15}
+
+test pixels-3.9 {invalid, < min} -constraints tk -body {
+ snit::pixels subtype -min 5
+ codecatch {subtype validate 4}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "4", expected pixels no less than 5}
+
+test pixels-3.10 {invalid, > max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ codecatch {subtype validate 21}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "21", expected pixels in range 5, 20}
+
+test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
+ snit::pixels subtype -min 5i -max 10i
+ codecatch {subtype validate 11i}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "11i", expected pixels in range 5i, 10i}
+
+#-----------------------------------------------------------------------
+# snit::stringtype
+
+test stringtype-1.1 {stringtype, valid string} -body {
+ snit::stringtype validate ""
+} -result {}
+
+test stringtype-2.1 {stringtype subtype: invalid -regexp} -body {
+ snit::stringtype subtype -regexp "\[A-Z"
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -regexp: "[A-Z"}
+
+test stringtype-2.2 {stringtype subtype: invalid -minlen} -body {
+ snit::stringtype subtype -minlen foo
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "foo"}
+
+test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body {
+ snit::stringtype subtype -maxlen foo
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -maxlen: "foo"}
+
+test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body {
+ snit::stringtype subtype -maxlen 1 -minlen 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test stringtype-2.5 {stringtype subtype: -minlen < 0} -body {
+ snit::stringtype subtype -minlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "-1"}
+
+test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body {
+ snit::stringtype subtype -maxlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test stringtype-3.1 {stringtype subtype: -glob, valid} -body {
+ snit::stringtype subtype -glob "*FOO*"
+ subtype validate 1FOO2
+} -cleanup {
+ subtype destroy
+} -result {1FOO2}
+
+test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -glob "*FOO*"
+ subtype validate 1foo2
+} -cleanup {
+ subtype destroy
+} -result {1foo2}
+
+test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body {
+ snit::stringtype subtype -glob "*FOO*"
+ codecatch {subtype validate 1foo2}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "1foo2"}
+
+test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -glob "*FOO*"
+ codecatch {subtype validate bar}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "bar"}
+
+test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body {
+ snit::stringtype subtype -regexp {^[A-Z]+$}
+ subtype validate FOO
+} -cleanup {
+ subtype destroy
+} -result {FOO}
+
+test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
+ subtype validate foo
+} -cleanup {
+ subtype destroy
+} -result {foo}
+
+test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body {
+ snit::stringtype subtype -regexp {^[A-Z]+$}
+ codecatch {subtype validate foo}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "foo"}
+
+test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
+ codecatch {subtype validate foo1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "foo1"}
+
+#-----------------------------------------------------------------------
+# snit::window
+
+test window-1.1 {window: valid} -constraints tk -body {
+ snit::window validate .
+} -result {.}
+
+test window-1.2 {window: invalid} -constraints tk -body {
+ codecatch {snit::window validate .nonesuch}
+} -result {INVALID invalid value ".nonesuch", value is not a window}
+
+test window-2.1 {window subtype: valid} -constraints tk -body {
+ snit::window subtype
+ subtype validate .
+} -cleanup {
+ subtype destroy
+} -result {.}
+
+test window-2.2 {window subtype: invalid} -constraints tk -body {
+ snit::window subtype
+ codecatch {subtype validate .nonesuch}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value ".nonesuch", value is not a window}
+
+#-----------------------------------------------------------------------
+# option -type specifications
+
+test optiontype-1.1 {-type is type object name} -body {
+ type dog {
+ option -akcflag -default no -type snit::boolean
+ }
+
+ dog create spot
+
+ # Set -akcflag to a boolean value
+ spot configure -akcflag yes
+ spot configure -akcflag 1
+ spot configure -akcflag on
+ spot configure -akcflag off
+
+ # Set -akcflag to an invalid value
+ spot configure -akcflag offf
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off}
+
+test optiontype-1.2 {-type is type specification} -body {
+ type dog {
+ option -color -default brown \
+ -type {snit::enum -values {brown black white golden}}
+ }
+
+ dog create spot
+
+ # Set -color to a valid value
+ spot configure -color brown
+ spot configure -color black
+ spot configure -color white
+ spot configure -color golden
+
+ # Set -color to an invalid value
+ spot configure -color green
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden}
+
+test optiontype-1.3 {-type catches invalid defaults} -body {
+ type dog {
+ option -color -default green \
+ -type {snit::enum -values {brown black white golden}}
+ }
+
+ dog spot
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden}
+
+
+#-----------------------------------------------------------------------
+# Bug Fixes
+
+test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body {
+ type dummy {
+ destructor {
+ # No content
+ }
+
+ constructor {args} {
+ $self configurelist $args
+ }
+
+ }
+} -cleanup {
+ rename ::dummy ""
+} -result ::dummy
+
+test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints {
+ tk
+} -body {
+ ::snit::widgetadaptor mylabel {
+ delegate method * to hull
+ delegate option * to hull
+
+ constructor {args} {
+ installhull using label
+ error "simulated error"
+ }
+ }
+
+ catch {mylabel .lab} result
+ list [info commands .lab] $result
+
+} -cleanup {
+ ::mylabel destroy
+} -result {{} {Error in constructor: simulated error}}
+
+test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints {
+ tk
+} -body {
+ ::snit::widget myframe {
+ delegate method * to hull
+ delegate option * to hull
+
+ constructor {args} {
+ error "simulated error"
+ }
+ }
+
+ catch {myframe .frm} result
+ list [info commands .frm] $result
+ } -cleanup {
+ ::myframe destroy
+} -result {{} {Error in constructor: simulated error}}
+
+test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints {
+ tk
+} -body {
+ snit::widget mywidget {
+ delegate method * to mylabel
+ delegate option * to mylabel
+
+ variable mylabel {}
+ }
+
+ mywidget .mylabel
+} -cleanup {
+ destroy .mylabel
+} -result {.mylabel}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+rename expect {}
+testsuiteCleanup
projects / scpubgit/TenDotTcl.git / blobdiff